home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-comp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-02-18  |  84.8 KB  |  3,306 lines
  1. /*  $Id: pl-comp.c,v 1.55 1998/02/18 13:56:43 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: compiler support
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12. #define CODE(c, n, a, e)    { n, c, a, e }
  13.  
  14. const code_info codeTable[] = {
  15. /*     ID        name         #args #xr */
  16.   CODE(I_NOP,        "i_nop",    0, 0),
  17.   CODE(I_ENTER,        "i_enter",    0, 0),
  18.   CODE(I_CALL,        "i_call",    1, CA1_PROC),
  19.   CODE(I_DEPART,    "i_depart",    1, CA1_PROC),
  20.   CODE(I_EXIT,        "i_exit",    0, 0),
  21.   CODE(B_FUNCTOR,    "b_functor",    1, CA1_FUNC),
  22.   CODE(B_RFUNCTOR,    "b_rfunctor",    1, CA1_FUNC),
  23.   CODE(H_FUNCTOR,    "h_functor",    1, CA1_FUNC),
  24.   CODE(H_RFUNCTOR,    "h_rfunctor",    1, CA1_FUNC),
  25.   CODE(I_POPF,        "i_pop",    0, 0),
  26.   CODE(B_VAR,        "b_var",    1, 0),
  27.   CODE(H_VAR,        "h_var",    1, 0),
  28.   CODE(B_CONST,        "b_const",    1, CA1_DATA),
  29.   CODE(H_CONST,        "h_const",    1, CA1_DATA),
  30.   CODE(H_INDIRECT,    "h_indirect",    0, CA1_STRING),
  31.   CODE(B_INTEGER,    "b_integer",    1, CA1_INTEGER),
  32.   CODE(H_INTEGER,    "h_integer",    1, CA1_INTEGER),
  33.   CODE(B_FLOAT,        "b_float",    2, CA1_FLOAT),
  34.   CODE(H_FLOAT,        "h_float",    2, CA1_FLOAT),
  35.   CODE(B_FIRSTVAR,    "b_firstvar",    1, 0),
  36.   CODE(H_FIRSTVAR,    "h_firstvar",    1, 0),
  37.   CODE(B_VOID,        "b_void",    0, 0),
  38.   CODE(H_VOID,        "h_void",    0, 0),
  39.   CODE(B_ARGFIRSTVAR,    "b_argfirstvar",1, 0),
  40.   CODE(B_ARGVAR,    "b_argvar",    1, 0),
  41.   CODE(H_NIL,        "h_nil",    0, 0),
  42.   CODE(B_NIL,        "b_nil",    0, 0),
  43.   CODE(H_LIST,        "h_list",    0, 0),
  44.   CODE(H_RLIST,        "h_rlist",    0, 0),
  45.   CODE(B_LIST,        "h_list",    0, 0),
  46.   CODE(B_RLIST,        "h_rlist",    0, 0),
  47.   CODE(B_VAR0,        "b_var0",    0, 0),
  48.   CODE(B_VAR1,        "b_var1",    0, 0),
  49.   CODE(B_VAR2,        "b_var2",    0, 0),
  50.   CODE(I_USERCALL0,    "i_usercall0",    0, 0),
  51.   CODE(I_USERCALLN,    "i_usercalln",    1, 0),
  52.   CODE(I_CUT,        "i_cut",    0, 0),
  53.   CODE(I_APPLY,        "i_apply",    0, 0),
  54.   CODE(A_ENTER,        "a_enter",    0, 0),
  55.   CODE(A_INTEGER,    "a_integer",    1, CA1_INTEGER),
  56.   CODE(A_DOUBLE,    "a_double",    2, CA1_FLOAT),
  57.   CODE(A_VAR0,        "a_var0",    0, 0),
  58.   CODE(A_VAR1,        "a_var1",    0, 0),
  59.   CODE(A_VAR2,        "a_var2",    0, 0),
  60.   CODE(A_VAR,        "a_var",    1, 0),
  61.   CODE(A_FUNC0,        "a_func0",    1, 0),
  62.   CODE(A_FUNC1,        "a_func1",    1, 0),
  63.   CODE(A_FUNC2,        "a_func2",    1, 0),
  64.   CODE(A_FUNC,        "a_func",    2, 0),
  65.   CODE(A_LT,        "a_lt",        0, 0),
  66.   CODE(A_GT,        "a_gt",        0, 0),
  67.   CODE(A_LE,        "a_le",        0, 0),
  68.   CODE(A_GE,        "a_ge",        0, 0),
  69.   CODE(A_EQ,        "a_eq",        0, 0),
  70.   CODE(A_NE,        "a_ne",        0, 0),
  71.   CODE(A_IS,        "a_is",        0, 0),
  72.   CODE(C_OR,        "c_or",        1, 0),
  73.   CODE(C_JMP,        "c_jmp",    1, 0),
  74.   CODE(C_MARK,        "c_mark",    1, 0),
  75.   CODE(C_CUT,        "c_cut",    1, 0),
  76.   CODE(C_IFTHENELSE,    "c_ifthenelse",    2, 0),
  77.   CODE(C_VAR,        "c_var",    1, 0),
  78.   CODE(C_END,        "c_end",    0, 0),
  79.   CODE(C_NOT,        "c_not",    2, 0),
  80.   CODE(C_FAIL,        "c_fail",    0, 0),
  81.   CODE(B_INDIRECT,    "b_indirect",    0, CA1_STRING),
  82. #if O_BLOCK
  83.   CODE(I_CUT_BLOCK,    "i_cut_block",    0, 0),
  84.   CODE(B_EXIT,        "b_exit",    0, 0),
  85. #endif
  86. #if O_INLINE_FOREIGNS
  87.   CODE(I_CALL_FV0,    "i_call_fv0",    1, CA1_PROC),
  88.   CODE(I_CALL_FV1,    "i_call_fv1",    2, CA1_PROC), /* , var */
  89.   CODE(I_CALL_FV2,    "i_call_fv2",    3, CA1_PROC), /* , var, var */
  90. #endif
  91.   CODE(I_FAIL,        "i_fail",    0, 0),
  92.   CODE(I_TRUE,        "i_true",    0, 0),
  93. #ifdef O_SOFTCUT
  94.   CODE(C_SOFTIF,    "c_softif",    2, 0),
  95.   CODE(C_SOFTCUT,    "c_softcut",    1, 0),
  96. #endif
  97.   CODE(I_EXITFACT,    "i_exitfact",    0, 0),
  98.   CODE(D_BREAK,        "d_break",    0, 0),
  99. #if O_CATCHTHROW
  100.   CODE(B_THROW,        "b_throw",    0, 0),
  101. #endif
  102. /*List terminator */
  103.   CODE(0,        NULL,        0, 0)
  104. };
  105.  
  106. forwards void    checkCodeTable(void);
  107.  
  108. static void
  109. checkCodeTable(void)
  110. { const code_info *ci;
  111.   unsigned int n;
  112.  
  113.   for(ci = codeTable, n = 0; ci->name != NULL; ci++, n++ )
  114.   { if ( ci->code != n )
  115.       sysError("Wrong entry in codeTable: %d", n);
  116.   }
  117.  
  118.   if ( --n != I_HIGHEST )
  119.     sysError("Mismatch in checkCodeTable()");
  120. }
  121.  
  122. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  123.             MAPPING VIRTUAL INSTRUCTIONS
  124.  
  125. The virtual machine interpreter can be optimised considerably by storing
  126. the code addressen with the clauses  rather  than  the  virtual  machine
  127. codes.  Normally the switch in translated (in pseudo assembler) to:
  128.  
  129. next_instruction:
  130.     r1 = *PC;
  131.     PC += sizeof(code);
  132.     if ( r1 > I_HIGHEST ) goto default;
  133.     r1 = jmp_table[r1 * 4];
  134.     goto r1;
  135.  
  136. This is rather silly.  Suppose  we  store  the  addresses  of  the  code
  137. segments  with  the  clauses  rather than the codes themselves, than the
  138. loop overhead can be reduced to:
  139.  
  140. next_instruction:
  141.     r1 = *PC;
  142.     PC += sizeof(code);
  143.     goto r1;
  144.  
  145. With gcc-2.1 or later, we can get this result without using assembler.
  146. All this required where a few pacthes in interpret(), the compiler and
  147. the wic (intermediate code)  generation  code.  The initialisation  is
  148. very critical:
  149.  
  150. The function interpret() (the VM interpreter)  declares a static array
  151. holding  the label  addresses      of the  various  virtual    machine
  152. instructions.  When it is  called,  it will  store the address of this
  153. table in  the  global  variable  interpreter_jmp_table.   the function
  154. initWamTable() than makes the two  translation tables wam_table[] (wam
  155. code --> label address and dewam_table[] (label address --> wam code).
  156. Note that initWamTable() calles prolog() and thus interpret to get the
  157. table with  the label addresses  out of interpret().   It does so with
  158. the  C-defined  predicate fail/0 (because   it  cannot  yet run prolog
  159. predicates).
  160.  
  161. BUGS:    Currently there are three  places were all the VM instructions
  162.     are  defined: pl-incl.h;  above and   pl-wam.c.  One day  this
  163.     should  be merged.  For  now, be very carefull  if you add  or
  164.     delete a VM instruction.
  165.  
  166. NOTE:    If the assert() fails, look at pl-wam.c: VMI(C_NOT, ... for
  167.     more information.
  168. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  169.  
  170. #if VMCODE_IS_ADDRESS
  171. void
  172. initWamTable(void)
  173. { int n;
  174.   code maxcoded, mincoded;
  175.  
  176.   if ( interpreter_jmp_table == NULL )
  177.     PL_next_solution(QID_EXPORT_WAM_TABLE);
  178.  
  179.   wam_table[0] = (code) (interpreter_jmp_table[0]);
  180.   maxcoded = mincoded = wam_table[0];
  181.  
  182.   for(n = 1; n <= I_HIGHEST; n++)
  183.   { wam_table[n] = (code) (interpreter_jmp_table[n]);
  184.     if ( wam_table[n] > maxcoded )
  185.       maxcoded = wam_table[n];
  186.     if ( wam_table[n] < mincoded )
  187.       mincoded = wam_table[n];
  188.   }
  189.   dewam_table_offset = mincoded;
  190.  
  191.   assert(wam_table[C_NOT] != wam_table[C_IFTHENELSE]);
  192.   dewam_table = (char *)allocHeap(((maxcoded-dewam_table_offset) + 1) *
  193.                   sizeof(char));
  194.   
  195.   for(n = 0; n <= I_HIGHEST; n++)
  196.     dewam_table[wam_table[n]-dewam_table_offset] = (char) n;
  197.  
  198.   checkCodeTable();
  199. }
  200.  
  201. #else /* VMCODE_IS_ADDRESS */
  202.  
  203. void
  204. initWamTable()
  205. { checkCodeTable();
  206. }
  207.  
  208. #endif /* VMCODE_IS_ADDRESS */
  209.  
  210. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  211. This module forms together  with  the  module  'pl-wam.c'  the  complete
  212. kernel  of  SWI-Prolog.   It  contains  the  compiler, the predicates to
  213. interface the compiler to Prolog and the  decompiler.   SWI-Prolog  does
  214. not  offer  a  Prolog  interpreter,  which  implies that common database
  215. predicates such as assert/1 and retract/1 have to do  compilation  resp.
  216. decompilation between the term representation used on the runtime stacks
  217. and the compiled representation used in the heap.
  218.  
  219. Compiling a clause takes three different stages.  First the variables of
  220. the clause are analysed.   This  phases  determines  `void'  (singleton)
  221. variables  and assigns offsets in the environment frame to each variable
  222. occurring in the clause that is not  singleton.   Variables  serving  on
  223. their  own as an argument in the head are allocated in the corresponding
  224. argument entry of the environment frame.  The others are allocated above
  225. the arguments in the environment frame.   Singleton  variables  are  not
  226. allocated at all.
  227.  
  228. Second  unification  code  for  the  head  is  produced.   Finally   the
  229. subclauses  are  translated.   Most  vital  from  the  point  of view of
  230. performance is to distinguis between the first time an  entry  from  the
  231. variable  array  is addressed and the following times: the first time we
  232. KNOW the field should be a variable and copying the value  or  making  a
  233. reference  is  the  appropriate action.  This both saves us the variable
  234. test and the need to turn the variable array of  the  environment  frame
  235. really into an array of variables.
  236.  
  237.             ANALYSING VARIABLES
  238.  
  239. First of all the clause is scanned and all  variables  are  instantiated
  240. with  a  structure  that  mimics  a term, but isn't one.  For historical
  241. reasons this is the term $VAR$/1.  Future versions will  use  a  functor
  242. which  is  impossible  to  conflict  with  the user's program.  For each
  243. variable it's address is stored, as well  as  the  number  of  times  it
  244. occurred in the clause.
  245. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  246.  
  247. forwards bool    analyse_variables(Word, Word, int, int*);
  248. forwards int    analyseVariables2(Word, int, int, int);
  249.  
  250. #if O_COMPILE_ARITH
  251. #define A_NOTARITH    0
  252. #define A_OK        1
  253. #define A_ERROR        2
  254. #endif /* O_COMPILE_ARITH */
  255.  
  256. typedef struct _varDef
  257. { word        functor;        /* mimic a functor (FUNCTOR_var1) */
  258.   Word        address;        /* address of the variable */
  259.   int        times;            /* occurences */
  260.   int        offset;            /* offset in environment frame */
  261. } vardef;
  262.  
  263. #define vardefs        (LD->comp._vardefs)
  264. #define nvardefs    (LD->comp._nvardefs)
  265. #define filledVars    (LD->comp._filledVars)
  266.  
  267. static VarDef
  268. getVarDef(int i)
  269. { VarDef vd;
  270.  
  271.   if ( i >= nvardefs )
  272.   { VarDef *vdp;
  273.     int nvd, n;
  274.  
  275.     if ( nvardefs )
  276.     { nvd = nvardefs * 2;
  277.       vardefs = realloc(vardefs, sizeof(VarDef) * nvd);
  278.     } else
  279.     { nvd = 32;
  280.       vardefs = malloc(sizeof(VarDef) * nvd);
  281.     }
  282.     if ( !vardefs )
  283.       outOfCore();
  284.  
  285.     for(vdp = &vardefs[nvardefs], n=nvardefs; n++ < nvd; )
  286.       *vdp++ = NULL;
  287.     nvardefs = nvd;
  288.   }
  289.  
  290.   if ( !(vd = vardefs[i]) )
  291.   { vd = vardefs[i] = allocHeap(sizeof(vardef));
  292.     memset(vd, 0, sizeof(*vd));
  293.     vd->functor = FUNCTOR_var1;
  294.   }
  295.  
  296.   return vd;
  297. }
  298.  
  299. #define VAROFFSET(var) ( (var) + ARGOFFSET / (int) sizeof(word) )
  300.  
  301. int
  302. get_head_and_body_clause(term_t clause,
  303.              term_t head, term_t body, Module *m)
  304. { term_t tmp = PL_new_term_ref();
  305.   Module m0 = NULL;
  306.  
  307.   if ( m )
  308.     m0 = *m;
  309.   TRY(PL_strip_module(clause, &m0, tmp));
  310.  
  311.   if ( PL_is_functor(tmp, FUNCTOR_prove2) )
  312.   { PL_get_arg(1, tmp, head);
  313.     PL_get_arg(2, tmp, body);
  314.     PL_strip_module(head, &m0, head);
  315.   } else
  316.   { PL_put_term(head, tmp);        /* facts */
  317.     PL_put_atom(body, ATOM_true);
  318.   }
  319.   
  320.   DEBUG(9, pl_write(clause); Sdprintf(" --->\n\t");
  321.        Sdprintf("%s:", stringAtom(m0->name));
  322.        pl_write(head); Sdprintf(" :- "); pl_write(body); Sdprintf("\n"));
  323.  
  324.   if ( m )
  325.     *m = m0;
  326.  
  327.   succeed;
  328. }
  329.  
  330.  
  331. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  332. Analyse the variables of a clause.  `term' is the term to  be  analysed, 
  333. which  is  either  a  fact  or  a  clause (:-/2) term.  First of all the
  334. functor and arity of the predicate are determined.   The  first  `arity'
  335. elements  of  the variable definition array are then cleared.  This part
  336. is used for sharing variables that occurr on their own in the head  with
  337. the  argument  part  of the environment frame instead of putting them in
  338. the variable part.
  339.  
  340. AnalyseVariables2() just scans the term, fills the  variable  definition
  341. array  and  binds  found  variables  to entries of this array.  The last
  342. argument indicates which plain argument we are processing.  It is set to
  343. -1 when called with the head.  While scaning the head  arguments  it  is
  344. set  to  the argument number.  For all other code it is arity (body code
  345. and nested terms of the head).  This is used for  the  argument/variable
  346. block merging.
  347.  
  348. After this scan the variable definition records are  scanned  to  assign
  349. offsets  and delete singleton variables.  We cannot leave out singletons
  350. that are sharing with the argument block.  Offset `0' is the first entry
  351. of the argument block, offset `arity' of the variable block.  Singletons
  352. are made variables again.
  353. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  354.  
  355. static bool
  356. analyse_variables(Word head, Word body, int arity, int *nv)
  357. { int nvars = 0;
  358.   int n;
  359.   int body_voids = 0;
  360.  
  361.   for(n=0; n<arity; n++)
  362.     getVarDef(n)->address = NULL;
  363.  
  364.   if ( (nvars = analyseVariables2(head, 0, arity, -1)) < 0 )
  365.     fail;
  366.   if (body != (Word) NULL)
  367.     if ( (nvars = analyseVariables2(body, nvars, arity, arity)) < 0 )
  368.       fail;
  369.  
  370.   for(n=0; n<arity+nvars; n++)
  371.   { VarDef vd = vardefs[n];
  372.  
  373.     assert(vd->functor == FUNCTOR_var1);
  374.     if (vd->address == (Word) NULL)
  375.       continue;
  376.     if (vd->times == 1)                /* ISVOID */
  377.     { setVar(*(vd->address));
  378.       vd->address = (Word) NULL;
  379.       if (n >= arity)
  380.     body_voids++;
  381.     } else
  382.       vd->offset = n - body_voids;
  383.   }
  384.  
  385.   filledVars = arity + nvars;
  386.   *nv = nvars - body_voids;
  387.   succeed;
  388. }
  389.  
  390. static int
  391. analyseVariables2(Word head, int nvars, int arity, int argn)
  392. { deRef(head);
  393.  
  394.   if ( isVar(*head) )
  395.   { VarDef vd;
  396.     int index = ((argn >= 0 && argn < arity) ? argn : (arity + nvars++));
  397.  
  398.     vd = getVarDef(index);
  399.     vd->address = head;
  400.     vd->times = 1;
  401.     *head = (index<<7)|TAG_ATOM|STG_GLOBAL; /* special mark */
  402.  
  403.     return nvars;
  404.   }
  405.  
  406.   if ( tagex(*head) == (TAG_ATOM|STG_GLOBAL) )
  407.   { VarDef vd = vardefs[(*head) >> 7];
  408.  
  409.     vd->times++;
  410.     return nvars;
  411.   }
  412.  
  413.   if ( isTerm(*head) )
  414.   { Functor f = valueTerm(*head);
  415.     int ar = arityFunctor(f->definition);
  416.  
  417.     head = f->arguments;
  418.     argn = ( argn < 0 ? 0 : arity );
  419.  
  420.     for(; ar > 0; ar--, head++, argn++)
  421.       nvars = analyseVariables2(head, nvars, arity, argn);
  422.   }
  423.  
  424.   return nvars;
  425. }
  426.  
  427. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  428. The compiler  itself.   First  it  calls  analyseVariables().  Next  the
  429. arguments  of  the  head  and  the subclauses are compiled.  Finally the
  430. bindings made by analyseVariables() are undone and the clause  is  saved
  431. in the heap.
  432.  
  433. compile() maintains an array of `used_var' (used variables).  This is to
  434. determine when a variable is used for the first time and thus a FIRSTVAR
  435. instruction is to be generated instead of a VAR one.
  436.  
  437. Note that the `variables' field of a clause is filled with the number of
  438. variables in the frame AND the arity.   This  saves  us  the  frame-size
  439. calculation at runtime.
  440. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  441.  
  442. #define isConjunction(w) hasFunctor(w, FUNCTOR_comma2)
  443.  
  444. #define A_HEAD    0x01            /* argument in head */
  445. #define A_BODY  0x02            /* argument in body */
  446. #define A_ARG    0x04            /* sub-argument */
  447. #define A_RIGHT    0x08            /* rightmost argument */
  448.  
  449. #define ISVOID 0            /* compileArgument produced H_VOID */
  450. #define NONVOID 1            /* ... anything else */
  451.  
  452. #define BLOCK(s) do { s; } while (0)
  453.  
  454. #define Output_0(ci, c)        addBuffer(&(ci)->codes, encode(c), code);
  455. #define Output_a(ci, c)        addBuffer(&(ci)->codes, c, code);
  456. #define Output_1(ci, c, a)    BLOCK(Output_0(ci, c); Output_a(ci, a))
  457. #define Output_2(ci, c, a0, a1)    BLOCK(Output_1(ci, c, a0); Output_a(ci, a1))
  458. #define Output_n(ci, p, n)    addMultipleBuffer(&(ci)->codes, p, n, word)
  459.  
  460. #define BITSPERINT (sizeof(int)*8)
  461.  
  462. #define PC(ci)        entriesBuffer(&(ci)->codes, code)
  463. #define OpCode(ci, pc)    (baseBuffer(&(ci)->codes, code)[pc])
  464.  
  465. typedef struct
  466. { int    isize;
  467.   int    entry[1];
  468. } var_table, *VarTable;
  469.  
  470. #undef struct_offsetp
  471. #define struct_offsetp(t, f) ((int)((t*)0)->f)
  472. #define sizeofVarTable(isize) (struct_offsetp(var_table, entry) + sizeof(int)*(isize))
  473.  
  474. #define mkCopiedVarTable(o) copyVarTable(alloca(sizeofVarTable(o->isize)), o)
  475.  
  476. typedef struct
  477. { Module    module;            /* module to compile into */
  478.   int        arity;            /* arity of top-goal */
  479.   Clause    clause;            /* clause we are constructing */
  480.   int        vartablesize;        /* size of the vartable */
  481.   tmp_buffer    codes;            /* scratch code table */
  482.   VarTable    used_var;        /* boolean array of used variables */
  483. } compileInfo;
  484.  
  485. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  486. Variable table operations.
  487. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  488.  
  489. forwards bool    compileBody(Word, code, compileInfo *);
  490. forwards int    compileArgument(Word, int, compileInfo *);
  491. forwards bool    compileSubClause(Word, code, compileInfo *);
  492. forwards bool    isFirstVar(VarTable vt, int n);
  493. forwards void    balanceVars(VarTable, VarTable, compileInfo *);
  494. forwards void    orVars(VarTable, VarTable);
  495. forwards void    setVars(Word t, VarTable);
  496. forwards Clause    compile(Word, Word, Module);
  497. #if O_COMPILE_ARITH
  498. forwards int    compileArith(Word, compileInfo *);
  499. forwards bool    compileArithArgument(Word, compileInfo *);
  500. #endif
  501.  
  502. static inline int
  503. isIndexedVarTerm(word w)
  504. { if ( tagex(w) == (TAG_ATOM|STG_GLOBAL) )
  505.   { VarDef v = vardefs[w>>7];
  506.     return v->offset;
  507.   }
  508.  
  509.   return -1;
  510. }
  511.  
  512. static void
  513. clearVarTable(compileInfo *ci)
  514. { int *pi = ci->used_var->entry;
  515.   int n   = ci->vartablesize;
  516.  
  517.   ci->used_var->isize = n;
  518.   while(--n >= 0)
  519.     *pi++ = 0;
  520. }
  521.  
  522. static bool
  523. isFirstVar(VarTable vt, register int n)
  524. { register int m  = 1 << (n % BITSPERINT);
  525.   register int *p = &vt->entry[n / BITSPERINT];
  526.   register int result;
  527.   
  528.   result = ((*p & m) == 0);
  529.   *p |= m;
  530.  
  531.   return result;
  532. }
  533.  
  534. static void
  535. balanceVars(VarTable valt1, VarTable valt2, compileInfo *ci)
  536. { int *p1 = &valt1->entry[0];
  537.   int *p2 = &valt2->entry[0];
  538.   int vts = ci->vartablesize;
  539.   register int n;
  540.  
  541.   for( n = 0; n < vts; p1++, p2++, n++ )
  542.   { register int m = (~(*p1) & *p2);
  543.  
  544.     if ( m )
  545.     { register int i;
  546.  
  547.       for(i = 0; i < BITSPERINT; i++)
  548.     if ( m & (1 << i) )
  549.       Output_1(ci, C_VAR, VAROFFSET(n * BITSPERINT + i));
  550.     }
  551.   }
  552. }
  553.  
  554. static void
  555. orVars(VarTable valt1, VarTable valt2)
  556. { register int *p1 = &valt1->entry[0];
  557.   register int *p2 = &valt2->entry[0];
  558.   register int n;
  559.  
  560.   for( n = 0; n < valt1->isize; n++ )
  561.     *p1++ |= *p2++;
  562. }
  563.  
  564. static void
  565. setVars(register Word t, VarTable vt)
  566. { int index;
  567.  
  568.   deRef(t);
  569.   if ( (index = isIndexedVarTerm(*t)) >= 0 )
  570.   { isFirstVar(vt, index);
  571.     return;
  572.   }
  573.  
  574.   if ( isTerm(*t) )
  575.   { int arity;
  576.  
  577.     arity = arityTerm(*t);
  578.     for(t = argTermP(*t, 0); arity > 0; t++, arity--)
  579.       setVars(t, vt);
  580.   }
  581. }
  582.  
  583.  
  584. static VarTable
  585. copyVarTable(VarTable to, VarTable from)
  586. { int *t = to->entry;
  587.   int *f = from->entry;
  588.   int n  = from->isize;
  589.  
  590.   to->isize = n;
  591.   while(--n>=0)
  592.     *t++ = *f++;
  593.  
  594.   return to;
  595. }
  596.  
  597.  
  598. static Clause
  599. compile(Word head, Word body, Module module)
  600. { compileInfo ci;            /* data base for the compiler */
  601.   Procedure proc;
  602.   Clause clause;
  603.   int nvars;
  604.  
  605.   deRef(head);
  606.   deRef(body);
  607.  
  608. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  609. Split the clause into its head and body and determine the procedure  the
  610. clause should belong to.
  611. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  612.  
  613.   if (isAtom(*head) )
  614.     proc = lookupProcedureToDefine(lookupFunctorDef(*head, 0), module);
  615.   else if (isTerm(*head) )
  616.     proc = lookupProcedureToDefine(functorTerm(*head), module);
  617.   else
  618.   { warning("compiler: illegal clause head");
  619.     return (Clause) NULL;
  620.   }
  621.   if ( !proc )
  622.     return NULL;
  623.  
  624.   if ( (ci.arity = proc->definition->functor->arity) > MAXARITY )
  625.   { warning("Compiler: arity too high (%d)\n", ci.arity);
  626.     return (Clause) NULL;
  627.   }
  628.  
  629.   DEBUG(9, Sdprintf("Splitted and found proc\n"));
  630.  
  631. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  632. Allocate the clause and fill initialise the field we already know.
  633. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  634.  
  635.   clause = (Clause) allocHeap(sizeof(struct clause));
  636.   clause->flags      = 0;
  637.   clause->code_size  = 0;
  638.   clause->procedure  = proc;
  639.   clause->source_no  = clause->line_no = 0;
  640.  
  641.   DEBUG(9, Sdprintf("clause struct initialised\n"));
  642.  
  643.   { register Definition def = proc->definition;
  644.  
  645.     if ( def->indexPattern && !(def->indexPattern & NEED_REINDEX) )
  646.       getIndex(argTermP(*head, 0),
  647.            def->indexPattern, 
  648.            def->indexCardinality,
  649.            &clause->index);
  650.     else
  651.       clause->index.key = clause->index.varmask = 0L;
  652.   }
  653.  
  654.   TRY( analyse_variables(head, body, ci.arity, &nvars) );
  655.   clause->prolog_vars = clause->variables = nvars + ci.arity;
  656.  
  657. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  658. Initialise the `compileInfo' structure.
  659. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  660.  
  661.   initBuffer(&ci.codes);
  662.   ci.module = module;
  663.   ci.clause = clause;
  664.  
  665.   ci.vartablesize = (nvars + ci.arity + BITSPERINT-1)/BITSPERINT;
  666.   ci.used_var = alloca(sizeofVarTable(ci.vartablesize));
  667.   clearVarTable(&ci);
  668.  
  669. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  670. First compile  the  head  of  the  term.   The  arguments  are  compiled
  671. left-to-right. `lastnonvoid' is maintained to delete void variables just
  672. before the I_ENTER instructions.
  673. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  674.  
  675.   { int n;
  676.     int lastnonvoid = 0;
  677.     Word arg;
  678.  
  679.     for ( arg = argTermP(*head, 0), n = 0; n < ci.arity; n++, arg++ )
  680.     { if ( compileArgument(arg, A_HEAD, &ci) == NONVOID )
  681.     lastnonvoid = PC(&ci);
  682.     }
  683.     seekBuffer(&ci.codes, lastnonvoid, code);
  684.   }
  685.  
  686. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  687. Now compile the body.
  688. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  689.  
  690.   if ( body && *body != ATOM_true )
  691.   { Output_0(&ci, I_ENTER);
  692.     compileBody(body, I_DEPART, &ci);
  693.     Output_0(&ci, I_EXIT);
  694.   } else
  695.   { set(clause, UNIT_CLAUSE);        /* fact (for decompiler) */
  696.     Output_0(&ci, I_EXITFACT);
  697.   }
  698.  
  699. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  700. Reset all variables we initialised to the variable analysis  functor  to
  701. become variables again.
  702. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  703.  
  704.   { int n;
  705.  
  706.     for(n=0; n < filledVars; n++)
  707.     { VarDef vd = vardefs[n];
  708.  
  709.       if ( vd->address != (Word) NULL )
  710.     setVar(*(vd->address));
  711.     }
  712.   }
  713.  
  714. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  715. Finish up the clause.
  716. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  717.  
  718.   { clause->codes = (Code) allocHeap(sizeOfBuffer(&ci.codes));
  719.     memcpy(clause->codes,baseBuffer(&ci.codes, code),sizeOfBuffer(&ci.codes));
  720.     clause->code_size = entriesBuffer(&ci.codes, code);
  721.  
  722.     discardBuffer(&ci.codes);
  723.  
  724.     GD->statistics.codes += clause->code_size;
  725.   }
  726.  
  727.   return clause;
  728. }
  729.  
  730. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  731. compileBody() compiles the clause's body.  Within a body,  a  number  of
  732. constructs are recognised:
  733.  
  734. SUBGOAL
  735.     For a subgoal we generate code to push the  arguments  on  the  next
  736.     stack  frame  and finally generate either I_CALL for normal calls or
  737.     I_DEPART for the last subgoal  of  the  clause  to  allow  for  tail
  738.     recursion optimisation.
  739.  
  740. VARIABLE or META CALL
  741.     Single variables or constructs  of  the  form  term:term  imply  the
  742.     generation of a metacall.
  743.  
  744. A ; B, A -> B, A -> B ; C, \+ A
  745.     The compilation of these statements are  a  bit  more  tricky.   Two
  746.     mechanisms support this compilation:
  747.     
  748.     C_MARK var    Mark for `soft-cut'
  749.     C_CUT  var    Cut alternatives generated since C_MARK var
  750.  
  751.     and
  752.     
  753.     C_OR jmp    Generate a choicepoint.  It the continuation
  754.             fails skip `jmp' instructions and continue
  755.             there.
  756.     C_JMP jmp    Just skip `jmp' instructions.
  757.  
  758.     This set  is  augmented  with  some  compound  statements  and  some
  759.     statements  with  different  names,  but equal semantics to help the
  760.     decompiler.  See pl-wam.c for more details.
  761.  
  762.     NOTE: A tricky bit now is that we  can  reach  the  same  point  via
  763.     different  paths.   Each of these paths may result in another set of
  764.     variables  already  instantiated.   This  gives  troubles  with  the
  765.     FIRSTVAR  type  of instructions.  to avoid such trouble the compiler
  766.     generates  SETVAR  instructions  to  balance  both   brances.    See
  767.     balanceVars();
  768. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  769.  
  770. static bool
  771. compileBody(register Word body, code call, register compileInfo *ci)
  772. { deRef(body);
  773.  
  774.   if ( isTerm(*body) )
  775.   { functor_t fd = functorTerm(*body);
  776.  
  777.     if ( fd == FUNCTOR_comma2 )            /* A , B */
  778.     { TRY( compileBody(argTermP(*body, 0), I_CALL, ci) );
  779.       return compileBody(argTermP(*body, 1), call, ci);
  780. #if O_COMPILE_OR
  781.     } else if ( fd == FUNCTOR_semicolon2 ||
  782.         fd == FUNCTOR_bar2 )        /* A ; B and (A -> B ; C) */
  783.     { register Word a0 = argTermP(*body, 0);
  784.       VarTable vsave = mkCopiedVarTable(ci->used_var);
  785.       VarTable valt1 = mkCopiedVarTable(ci->used_var);
  786.       VarTable valt2 = mkCopiedVarTable(ci->used_var);
  787.       int hard;
  788.       
  789.       setVars(argTermP(*body, 0), valt1);
  790.       setVars(argTermP(*body, 1), valt2);
  791.  
  792.       deRef(a0);
  793.       if ( (hard=hasFunctor(*a0, FUNCTOR_ifthen2)) || /* A  -> B ; C */
  794.        hasFunctor(*a0, FUNCTOR_softcut2) )        /* A *-> B ; C */
  795.       { int var = VAROFFSET(ci->clause->variables++);
  796.     int tc_or, tc_jmp;
  797.  
  798.     Output_2(ci, hard ? C_IFTHENELSE : C_SOFTIF, var, (code)0);
  799.     tc_or = PC(ci);
  800.     TRY( compileBody(argTermP(*a0, 0), I_CALL, ci) );    
  801.     Output_1(ci, hard ? C_CUT : C_SOFTCUT, var);
  802.     TRY( compileBody(argTermP(*a0, 1), call, ci) );    
  803.     balanceVars(valt1, valt2, ci);
  804.     Output_1(ci, C_JMP, (code)0);
  805.     tc_jmp = PC(ci);
  806.     OpCode(ci, tc_or-1) = (code)(PC(ci) - tc_or);
  807.     copyVarTable(ci->used_var, vsave);
  808.     TRY( compileBody(argTermP(*body, 1), call, ci) );
  809.     balanceVars(valt2, valt1, ci);
  810.     OpCode(ci, tc_jmp-1) = (code)(PC(ci) - tc_jmp);
  811.       } else                    /* A ; B */
  812.       { int tc_or, tc_jmp;
  813.  
  814.     Output_1(ci, C_OR, (code)0);
  815.     tc_or = PC(ci);
  816.     TRY( compileBody(argTermP(*body, 0), I_CALL, ci) );
  817.     balanceVars(valt1, valt2, ci);
  818.     Output_1(ci, C_JMP, (code)0);
  819.     tc_jmp = PC(ci);
  820.     OpCode(ci, tc_or-1) = (code)(PC(ci) - tc_or);
  821.     copyVarTable(ci->used_var, vsave);
  822.     TRY( compileBody(argTermP(*body, 1), call, ci) );
  823.     balanceVars(valt2, valt1, ci);
  824.     OpCode(ci, tc_jmp-1) = (code)(PC(ci) - tc_jmp);
  825.       }
  826.  
  827.       orVars(valt1, valt2);
  828.       copyVarTable(ci->used_var, valt1);
  829.  
  830.       succeed;
  831.     } else if ( fd == FUNCTOR_ifthen2 )        /* A -> B */
  832.     { int var = VAROFFSET(ci->clause->variables++);
  833.  
  834.       Output_1(ci, C_MARK, var);
  835.       TRY( compileBody(argTermP(*body, 0), I_CALL, ci) );
  836.       Output_1(ci, C_CUT, var);
  837.  
  838.       TRY( compileBody(argTermP(*body, 1), call, ci) );
  839.       Output_0(ci, C_END);
  840.       
  841.       succeed;
  842.     } else if ( fd == FUNCTOR_not_provable1 )        /* \+/1 */
  843.     { int var = VAROFFSET(ci->clause->variables++);
  844.       int tc_or;
  845.       VarTable vsave = mkCopiedVarTable(ci->used_var);
  846.  
  847.       Output_2(ci, C_NOT, var, (code)0);
  848.       tc_or = PC(ci);
  849.       TRY( compileBody(argTermP(*body, 0), I_CALL, ci) );    
  850.       Output_1(ci, C_CUT, var);
  851.       Output_0(ci, C_FAIL);
  852.       OpCode(ci, tc_or-1) = (code)(PC(ci) - tc_or);
  853.       copyVarTable(ci->used_var, vsave);
  854.       
  855.       succeed;
  856. #endif /* O_COMPILE_OR */
  857.     }
  858.   }
  859.  
  860.   TRY( compileSubClause(body, call, ci) );
  861.  
  862.   succeed;
  863. }
  864.  
  865.  
  866. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  867. compileArgument() is the key function of the compiler.  Its function  is
  868. to   generate  the  term  matching/construction  instructions  both  for
  869. arguments of the head as for arguments to subclauses.   It  distinguises
  870. three  different  places:  compiling plain arguments to the head (HEAD),
  871. arguments of terms occurring in the head (HEADARG) and body arguments
  872. (BODY).
  873.  
  874. The  isIndexedVar()  macro  detects  a   term   has   been   filled   by
  875. analyseVariables()  and  returns the offset of the variable, or -1 if it
  876. is not produced by this function.
  877.  
  878. compileArgument() returns ISVOID if a void instruction resulted from the
  879. compilation.  This is used to detect  the  ...ISVOID,  [I_ENTER,  I_POPF]
  880. sequences,  in  which  case  we  can leave out the VOIDS just before the
  881. I_ENTER or I_POPF instructions.
  882. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  883.  
  884. static int
  885. compileArgument(Word arg, int where, compileInfo *ci)
  886. { int index;
  887.   bool first;
  888.  
  889.   deRef(arg);
  890.  
  891. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  892. A void.  Generate either B_VOID or H_VOID.  Note that the  return  value
  893. ISVOID  is reserved for head variables only (B_VOID sets the location to
  894. be a variable, and thus cannot be removed if it is before an I_POPF.
  895. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  896.  
  897.   switch(tag(*arg))
  898.   { case TAG_VAR:
  899.       if (where & A_BODY)
  900.       { Output_0(ci, B_VOID);
  901.     return NONVOID;
  902.       }
  903.       Output_0(ci, H_VOID);
  904.       return ISVOID;
  905.     case TAG_INTEGER:
  906.       if ( storage(*arg) != STG_INLINE )
  907.       {    Output_1(ci, (where&A_HEAD) ? H_INTEGER : B_INTEGER, valBignum(*arg));
  908.     return NONVOID;
  909.       }
  910.       /* FALLTHROUGH for tagged integers */
  911.     case TAG_ATOM:
  912.       if ( tagex(*arg) == (TAG_ATOM|STG_GLOBAL) )
  913.     goto isvar;
  914.       if ( isNil(*arg) )
  915.       {    Output_0(ci, (where & A_BODY) ? B_NIL : H_NIL);
  916.       } else
  917.       { Output_1(ci, (where & A_BODY) ? B_CONST : H_CONST, *arg);
  918.       }
  919.       return NONVOID;
  920.     case TAG_FLOAT:
  921.     { Word p = valIndirectP(*arg);
  922.       Output_2(ci, (where & A_BODY) ? B_FLOAT : H_FLOAT, p[0], p[1]);
  923.       return NONVOID;
  924.     }
  925.     case TAG_STRING:
  926.     { Word p = addressIndirect(*arg);
  927.  
  928.       int n  = wsizeofInd(*p);
  929.       Output_0(ci, (where & A_HEAD) ? H_INDIRECT : B_INDIRECT);
  930.       Output_n(ci, p, n+1);
  931.       return NONVOID;
  932.     }
  933.   }
  934.  
  935. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  936. Non-void variables. There are many cases for this.
  937. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  938.  
  939. isvar:
  940.   if ( (index = isIndexedVarTerm(*arg)) >= 0 )
  941.   { first = isFirstVar(ci->used_var, index);
  942.  
  943.     if ( index < ci->arity )        /* variable on its own in the head */
  944.     { if ( where & A_BODY )
  945.       { if ( where & A_ARG )
  946.     { Output_0(ci, B_ARGVAR);
  947.     } else
  948.     { if ( index < 3 )
  949.       { Output_0(ci, B_VAR0 + index);
  950.         return NONVOID;
  951.       }
  952.       Output_0(ci, B_VAR);
  953.     }
  954.       } else                /* head */
  955.       { if ( !(where & A_ARG) && first )
  956.     { Output_0(ci, H_VOID);
  957.       return ISVOID;
  958.     }
  959.     Output_0(ci, H_VAR);
  960.       }
  961.       Output_a(ci, VAROFFSET(index));
  962.  
  963.       return NONVOID;
  964.     }
  965.  
  966.     /* normal variable (i.e. not shared in the head and non-void) */
  967.     if( where & A_BODY )
  968.     { if ( where & A_ARG )
  969.       { Output_0(ci, first ? B_ARGFIRSTVAR : B_ARGVAR);
  970.       } else
  971.       { if ( index < 3 && !first )
  972.     { Output_0(ci, B_VAR0 + index);
  973.       return NONVOID;
  974.     }
  975.     Output_0(ci, first ? B_FIRSTVAR : B_VAR);
  976.       }
  977.     } else
  978.     { Output_0(ci, first ? H_FIRSTVAR : H_VAR);
  979.     }
  980.  
  981.     Output_a(ci, VAROFFSET(index));
  982.  
  983.     return NONVOID;
  984.   }
  985.  
  986.   assert(isTerm(*arg));
  987.     
  988.   { int ar;
  989.     int lastnonvoid;
  990.     functor_t fdef;
  991.     int isright = (where & A_RIGHT);
  992.  
  993.     fdef = functorTerm(*arg);
  994.     if ( fdef == FUNCTOR_dot2 )
  995.     { code c;
  996.  
  997.       if ( (where & A_HEAD) )        /* index in array! */
  998.     c = (isright ? H_RLIST : H_LIST);
  999.       else
  1000.     c = (isright ? B_RLIST : B_LIST);
  1001.  
  1002.       Output_0(ci, c);
  1003.     } else
  1004.     { code c;
  1005.  
  1006.       if ( (where & A_HEAD) )        /* index in array! */
  1007.     c = (isright ? H_RFUNCTOR : H_FUNCTOR);
  1008.       else
  1009.     c = (isright ? B_RFUNCTOR : B_FUNCTOR);
  1010.  
  1011.       Output_1(ci, c, (word)fdef);
  1012.     }
  1013.     lastnonvoid = PC(ci);
  1014.     ar = arityFunctor(fdef);
  1015.     where &= ~A_RIGHT;
  1016.     for(arg = argTermP(*arg, 0); ar > 0; ar--, arg++)
  1017.     { where |= A_ARG;
  1018.  
  1019.       if ( ar == 1 )
  1020.     where |= A_RIGHT;
  1021.  
  1022.       if ( compileArgument(arg, where, ci) == NONVOID )
  1023.     lastnonvoid = PC(ci);
  1024.     }
  1025.     seekBuffer(&ci->codes, lastnonvoid, code);
  1026.     if ( !isright )
  1027.       Output_0(ci, I_POPF);
  1028.  
  1029.     return NONVOID;
  1030.   }
  1031. }
  1032.  
  1033.  
  1034. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1035. The task of compileSubClause() is to  generate  code  for  a  subclause.
  1036. First  it will call compileArgument for each argument to the call.  Then
  1037. an instruction to call the procedure is added.  Before doing all this it
  1038. will check for the subclause just beeing a variable or the cut.
  1039. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1040.  
  1041. static bool
  1042. compileSubClause(register Word arg, code call, compileInfo *ci)
  1043. { Module tm = ci->module;
  1044.  
  1045.   deRef(arg);
  1046. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1047. A non-void variable. Create a I_USERCALL0 instruction for it.
  1048. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1049.   if ( isIndexedVarTerm(*arg) >= 0 )
  1050.   { compileArgument(arg, A_BODY, ci);
  1051.     Output_0(ci, I_USERCALL0);
  1052.     succeed;
  1053.   }
  1054.  
  1055.   if ( isTerm(*arg) )
  1056.   {
  1057. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1058. If the argument is of the form <Module>:<Goal>, <Module> is an atom  and
  1059. <Goal>  is  nonvar  then compile to the specified module.  Otherwise use
  1060. the meta-call mechanism (BUG: `user:hello:foo' is called  via  meta-call
  1061. mechanism, but this only is a bit slower).
  1062.  
  1063. This is a bit more complex then expected: foo:assert(baz) should  assert
  1064. baz/0  into module foo.  In general: the context module should be set to
  1065. the appropriate value.  This needs a  new  virtual  machine  instruction
  1066. that  handles  calls  with  specified context module.  For the moment we
  1067. will use the meta-call mechanism for all these types of calls.
  1068. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1069.     if ( functorTerm(*arg) == FUNCTOR_module2 )
  1070.     {
  1071.   /*                            SEE COMMENT ABOVE
  1072.       register Word mp, g;
  1073.  
  1074.       mp = argTermP(*arg, 0); deRef(mp);
  1075.       if ( isAtom(*mp) )
  1076.       { g = argTermP(*arg, 1); deRef(g);
  1077.     if ( isIndexedVarTerm(*g) < 0 )
  1078.     { arg = g;
  1079.       tm = lookupModule(*mp);
  1080.       goto cont;
  1081.     }
  1082.       }
  1083.   */
  1084.  
  1085.       compileArgument(arg, A_BODY, ci);
  1086.       Output_0(ci, I_USERCALL0);
  1087.       succeed;
  1088.     }
  1089. /*  cont: */
  1090.  
  1091. #if O_COMPILE_ARITH
  1092.     if ( GD->cmdline.optimise )
  1093.     { switch( compileArith(arg, ci) )
  1094.       { case A_OK:    succeed;
  1095.     case A_ERROR:    fail;
  1096.       }
  1097.     }
  1098. #endif /* O_COMPILE_ARITH */
  1099.  
  1100. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1101. Term, not a variable and not a module call.  Compile the  arguments  and
  1102. generate  the  call  instruction.   Note  this  codes traps the $apply/2
  1103. operator.
  1104. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1105.     { functor_t functor = functorTerm(*arg);
  1106.       FunctorDef fdef = valueFunctor(functor);
  1107.       Procedure proc = lookupProcedure(functor, tm);
  1108.       int ar = fdef->arity;
  1109.  
  1110. #ifdef O_INLINE_FOREIGNS
  1111. #define MAX_FV 2
  1112.       if ( true(fdef, INLINE_F) && ar <= MAX_FV )
  1113.       { int n;
  1114.     int vars[MAX_FV];
  1115.  
  1116.     for(n = 0; n < ar; n++)
  1117.     { Word a = argTermP(*arg, n);
  1118.  
  1119.       deRef(a);
  1120.       if ( (vars[n] = isIndexedVarTerm(*a)) >= 0 )
  1121.         continue;
  1122.  
  1123.       goto non_fv;
  1124.     }
  1125.  
  1126.     for(n = 0; n < ar; n++)
  1127.     { if ( isFirstVar(ci->used_var, vars[n]) )
  1128.       { Output_1(ci, C_VAR, VAROFFSET(vars[n]));
  1129.       }
  1130.     }
  1131.  
  1132.         Output_1(ci, I_CALL_FV0 + ar, (code)proc);
  1133.     for(n=0; n<ar; n++)
  1134.       Output_a(ci, VAROFFSET(vars[n]));
  1135.  
  1136.     succeed;
  1137.       non_fv:;
  1138.       }
  1139. #endif /*O_INLINE_FOREIGNS*/
  1140.  
  1141.       for(arg = argTermP(*arg, 0); ar > 0; ar--, arg++)
  1142.     compileArgument(arg, A_BODY, ci);
  1143.  
  1144.       if ( fdef->name == ATOM_call )
  1145.       { Output_1(ci, I_USERCALLN, (code)(fdef->arity - 1));
  1146.     succeed;
  1147.       } else if ( functor == FUNCTOR_apply2 )
  1148.       { Output_0(ci, I_APPLY);
  1149.     succeed;
  1150. #if O_BLOCK
  1151.       } else if ( functor == FUNCTOR_dcut1 )
  1152.       { Output_0(ci, I_CUT_BLOCK);
  1153.     succeed;
  1154.       } else if ( functor == FUNCTOR_dexit2 )
  1155.       { Output_0(ci, B_EXIT);
  1156.     succeed;
  1157. #endif
  1158. #if O_CATCHTHROW
  1159.       } else if ( functor == FUNCTOR_dthrow1 )
  1160.       { Output_0(ci, B_THROW);
  1161.     succeed;
  1162. #endif
  1163.       }
  1164.       Output_1(ci, call, (code) proc);
  1165.  
  1166.       succeed;
  1167.     }
  1168.   }
  1169.  
  1170.   if ( isAtom(*arg) )
  1171.   { if ( *arg == ATOM_cut )
  1172.     { Output_0(ci, I_CUT);
  1173.     } else if ( *arg == ATOM_true )
  1174.     { Output_0(ci, I_TRUE);
  1175.     } else if ( *arg == ATOM_fail )
  1176.     { Output_0(ci, I_FAIL);
  1177.     } else
  1178.     { functor_t fdef = lookupFunctorDef(*arg, 0);
  1179.       code cproc = (code) lookupProcedure(fdef, tm);
  1180.  
  1181. #ifdef O_INLINE_FOREIGNS
  1182.       if ( true(valueFunctor(fdef), INLINE_F) )
  1183.       { Output_1(ci, I_CALL_FV0, cproc);
  1184.       } else
  1185. #endif /*O_INLINE_FOREIGNS*/
  1186.       { Output_1(ci, call, cproc);
  1187.       }
  1188.     }
  1189.  
  1190.     succeed;
  1191.   }
  1192.     
  1193.   return warning("assert/1: illegal clause");
  1194. }
  1195.  
  1196. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1197. Arithmetic compilation compiles is/2, >/2, etc.  Instead of building the
  1198. compound terms holding the arithmetic expression as  a  whole  and  then
  1199. calling  is/2,  etc.  to evaluate the result, a stack machine is used to
  1200. compute the value.  The ARGP virtual machine register, normally used  in
  1201. body  mode to push the arguments to the next functioncall now is used to
  1202. push the arguments to the arithmetic functions.  Normally, a term f(a,b)
  1203. is translated to:
  1204.  
  1205.     * Create f and set ARGP to point to first argument of f
  1206.     * Push a and b via ARGP
  1207.     * pop ARGP
  1208.  
  1209. This constructs a term.  In arithmetic mode, we generate:
  1210.  
  1211.     * Push a and b via ARGP
  1212.     * Call f/2 to pick the top two words from the stack and push
  1213.       the result back onto it.
  1214.  
  1215. This has two advantages: No term is created on the global stack and  the
  1216. mapping  between  the  term  and  the arithmetic function is done by the
  1217. compiler rather than the evaluation routine.
  1218.  
  1219. OUT-OF-DATE: now pushes *numbers* rather then tagged Prolog data structures.
  1220. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1221.  
  1222. #if O_COMPILE_ARITH
  1223. static int
  1224. compileArith(Word arg, compileInfo *ci)
  1225. { code a_func;
  1226.   functor_t fdef = functorTerm(*arg);
  1227.  
  1228.   if      ( fdef == FUNCTOR_ar_equals2 )    a_func = A_EQ;    /* =:= */
  1229.   else if ( fdef == FUNCTOR_ar_not_equal2 )    a_func = A_NE;    /* =\= */
  1230.   else if ( fdef == FUNCTOR_smaller2 )         a_func = A_LT;    /* < */
  1231.   else if ( fdef == FUNCTOR_larger2 )        a_func = A_GT;    /* > */
  1232.   else if ( fdef == FUNCTOR_smaller_equal2 )    a_func = A_LE;    /* =< */
  1233.   else if ( fdef == FUNCTOR_larger_equal2 )    a_func = A_GE;    /* >= */
  1234.   else if ( fdef == FUNCTOR_is2 )                /* is */
  1235.   { if ( !compileArgument(argTermP(*arg, 0), A_BODY, ci) )
  1236.       return A_ERROR;
  1237.     Output_0(ci, A_ENTER);
  1238.     if ( !compileArithArgument(argTermP(*arg, 1), ci) )
  1239.       return A_ERROR;
  1240.     Output_0(ci, A_IS);
  1241.     return A_OK;
  1242.   } else
  1243.     return A_NOTARITH;            /* not arith function */
  1244.  
  1245.   Output_0(ci, A_ENTER);
  1246.   if ( !compileArithArgument(argTermP(*arg, 0), ci) ||
  1247.        !compileArithArgument(argTermP(*arg, 1), ci) )
  1248.     return A_ERROR;
  1249.  
  1250.   Output_0(ci, a_func);
  1251.  
  1252.   return A_OK;
  1253. }
  1254.  
  1255.  
  1256. static bool
  1257. compileArithArgument(Word arg, compileInfo *ci)
  1258. { int index;
  1259.  
  1260.   deRef(arg);
  1261.  
  1262.   if ( isInteger(*arg) )
  1263.   { Output_1(ci, A_INTEGER, valInteger(*arg));
  1264.     succeed;
  1265.   }
  1266.   if ( isReal(*arg) )
  1267.   { union
  1268.     { double f;
  1269.       word   w[2];
  1270.     } v;
  1271.     v.f = valReal(*arg);
  1272.     Output_2(ci, A_DOUBLE, v.w[0], v.w[1]);
  1273.     succeed;
  1274.   }
  1275.                     /* variable */
  1276.   if ( (index = isIndexedVarTerm(*arg)) >= 0 )
  1277.   { int first = isFirstVar(ci->used_var, index);
  1278.  
  1279.     if ( index < ci->arity )        /* shared in the head */
  1280.     { if ( index < 3 )
  1281.       { Output_0(ci, A_VAR0 + index);
  1282.     succeed;
  1283.       }
  1284.       Output_0(ci, A_VAR);
  1285.     } else
  1286.     { if ( index < 3 && !first )
  1287.       { Output_0(ci, A_VAR0 + index);
  1288.         succeed;
  1289.       }
  1290.       if ( first )
  1291.     return warning("Compiler: Unbound variable in arithmetic expression");
  1292.       Output_0(ci, A_VAR);
  1293.     }          
  1294.     Output_a(ci, VAROFFSET(index));
  1295.     succeed;
  1296.   }
  1297.  
  1298.   if ( isVar(*arg) )            /* void variable */
  1299.     return warning("Compiler: void variable in arithmetic expression");
  1300.  
  1301.   { functor_t fdef;
  1302.     int n, ar;
  1303.     Word a;
  1304.  
  1305.     if ( isAtom(*arg) )
  1306.     { fdef = lookupFunctorDef(*arg, 0);
  1307.       ar = 0;
  1308.       a = NULL;
  1309.     } else if ( isTerm(*arg) )
  1310.     { fdef = functorTerm(*arg);
  1311.       ar = arityFunctor(fdef);
  1312.       a = argTermP(*arg, 0);      
  1313.     } else
  1314.       return warning("Illegal argument to arithmic function");
  1315.  
  1316.     if ( (index = indexArithFunction(fdef, ci->module)) < 0 )
  1317.       return warning("%s/%d: unknown arithmetic operator",
  1318.              stringAtom(nameFunctor(fdef)), ar);
  1319.  
  1320.     for(n=0; n<ar; a++, n++)
  1321.       TRY( compileArithArgument(a, ci) );
  1322.  
  1323.     switch(ar)
  1324.     { case 0:    Output_1(ci, A_FUNC0, index); break;
  1325.       case 1:    Output_1(ci, A_FUNC1, index); break;
  1326.       case 2:    Output_1(ci, A_FUNC2, index); break;
  1327.       default:  Output_2(ci, A_FUNC,  index, (code) ar); break;
  1328.     }
  1329.  
  1330.     succeed;
  1331.   }
  1332. }
  1333. #endif /* O_COMPILE_ARITH */
  1334.  
  1335.  
  1336.         /********************************
  1337.         *  PROLOG DATA BASE MANAGEMENT  *
  1338.         *********************************/
  1339.  
  1340. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1341. Assert is used by assert[az] and record_clause/2 (used by  the  compiler
  1342. toplevel).  It asserts a term in the database, either at the start or at
  1343. the  end  of  the predicate and if a file is present, updates the source
  1344. administration, checks for reconsults, etc.
  1345.  
  1346. The warnings should help explain what is going on here.
  1347. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1348.  
  1349. Clause
  1350. assert_term(term_t term, int where, SourceLoc loc)
  1351. { Clause clause;
  1352.   Procedure proc;
  1353.   Definition def;
  1354.   Module source_module = (loc ? LD->modules.source : (Module) NULL);
  1355.   Module module = source_module;
  1356.   term_t tmp  = PL_new_term_ref();
  1357.   term_t head = PL_new_term_ref();
  1358.   term_t body = PL_new_term_ref();
  1359.  
  1360.   if ( !PL_strip_module(term, &module, tmp) ||
  1361.        !get_head_and_body_clause(tmp, head, body, &module) )
  1362.   { warning("compiler: illegal clause");
  1363.     return (Clause) NULL;
  1364.   }
  1365.  
  1366.   DEBUG(9, Sdprintf("compiling "); pl_write(term); Sdprintf(" ... "););
  1367.   if ( !(clause = compile(valTermRef(head), valTermRef(body), module)) )
  1368.     return NULL;
  1369.   DEBUG(9, Sdprintf("ok\n"));
  1370.   proc = clause->procedure;
  1371.   def = proc->definition;
  1372.  
  1373. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1374. If loc is defined, we are called from record_clause/2.  This code takes
  1375. care of reconsult, redefinition, etc.
  1376. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1377.  
  1378.   if ( loc )
  1379.   { SourceFile sf;
  1380.  
  1381.     sf = lookupSourceFile(loc->file);
  1382.     clause->line_no   = loc->line;
  1383.     clause->source_no = sf->index;
  1384.  
  1385.     if ( def->module != module )
  1386.     { if ( true(def->module, SYSTEM) )
  1387.         warning("Attempt to redefine a system predicate: %s", 
  1388.         procedureName(proc));
  1389.       else
  1390.     warning("%s/%d already imported from module %s", 
  1391.         stringAtom(def->functor->name), 
  1392.         def->functor->arity, 
  1393.         stringAtom(proc->definition->module->name) );
  1394.       freeClause(clause);
  1395.       return NULL;
  1396.     }
  1397.  
  1398.     if ( proc == sf->current_procedure )
  1399.       return assertProcedure(proc, clause, where) ? clause : NULL;
  1400.  
  1401.     if ( def->definition.clauses )    /* i.e. is defined */
  1402.     { if ( true(def, LOCKED) && !SYSTEM_MODE && false(def, DYNAMIC|MULTIFILE) )
  1403.       { warning("Attempt to redefine a system predicate: %s",
  1404.         procedureName(proc));
  1405.     freeClause(clause);
  1406.     return NULL;
  1407.       }
  1408.  
  1409.       if ( true(def, FOREIGN) )
  1410.       { abolishProcedure(proc, module);
  1411.     warning("Redefined: foreign predicate %s", procedureName(proc));
  1412.       }
  1413.  
  1414.       if ( false(def, MULTIFILE) )
  1415.       { ClauseRef first = def->definition.clauses;
  1416.  
  1417.     while ( first && true(first->clause, ERASED) )
  1418.       first = first->next;
  1419.  
  1420.     if ( first && first->clause->source_no == sf->index )
  1421.     { if ( (debugstatus.styleCheck & DISCONTIGUOUS_STYLE) &&
  1422.            false(def, DISCONTIGUOUS) )
  1423.         warning("Clauses of %s are not together in the source file", 
  1424.             procedureName(proc));
  1425.     } else
  1426.     { abolishProcedure(proc, module);
  1427.       warning("Redefined: %s", procedureName(proc));
  1428.     }
  1429.       }
  1430.  
  1431.       addProcedureSourceFile(sf, proc);
  1432.       sf->current_procedure = proc;
  1433.       
  1434.       return assertProcedure(proc, clause, where) ? clause : NULL;
  1435.     }
  1436.  
  1437. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1438. This `if' locks predicates as system predicates  if  we  are  in  system
  1439. mode, the predicate is still undefined and is not dynamic or multifile.
  1440. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1441.  
  1442.     if ( SYSTEM_MODE && false(def, SYSTEM) )
  1443.       set(def, SYSTEM|HIDE_CHILDS|LOCKED);
  1444.  
  1445.     addProcedureSourceFile(sf, proc);
  1446.     sf->current_procedure = proc;
  1447.     return assertProcedure(proc, clause, where) ? clause : NULL;
  1448.   }
  1449.  
  1450.   /* assert[az]/1 */
  1451.  
  1452.   if ( def->module != module && false(def, DYNAMIC) )
  1453.   { warning("Attempt to redefine an imported predicate %s", 
  1454.                   procedureName(proc) );
  1455.     freeClause(clause);
  1456.     return (Clause) NULL;
  1457.   }
  1458.   set(def, DYNAMIC);            /* Make dynamic on first assert */
  1459.  
  1460.   return assertProcedure(proc, clause, where) == FALSE ? (Clause) NULL
  1461.                                : clause;
  1462. }
  1463.  
  1464. word
  1465. pl_assertz(term_t term)
  1466. { return assert_term(term, CL_END, NULL) == NULL ? FALSE : TRUE;
  1467. }
  1468.  
  1469. word
  1470. pl_asserta(term_t term)
  1471. { return assert_term(term, CL_START, NULL) == NULL ? FALSE : TRUE;
  1472. }
  1473.  
  1474.  
  1475. word
  1476. pl_assertz2(term_t term, term_t ref)
  1477. { Clause clause = assert_term(term, CL_END, NULL);
  1478.  
  1479.   if (clause == (Clause)NULL)
  1480.     fail;
  1481.  
  1482.   return PL_unify_pointer(ref, clause);
  1483. }
  1484.  
  1485.  
  1486. word
  1487. pl_asserta2(term_t term, term_t ref)
  1488. { Clause clause = assert_term(term, CL_START, NULL);
  1489.  
  1490.   if (clause == (Clause)NULL)
  1491.     fail;
  1492.  
  1493.   return PL_unify_pointer(ref, clause);
  1494. }
  1495.  
  1496.  
  1497. word
  1498. pl_record_clause(term_t term, term_t file, term_t ref)
  1499. { Clause clause;
  1500.   sourceloc loc;
  1501.  
  1502.   if ( PL_get_atom(file, &loc.file) )    /* just the name of the file */
  1503.   { loc.line = source_line_no;
  1504.   } else if ( PL_is_functor(file, FUNCTOR_module2) )
  1505.   { term_t arg = PL_new_term_ref();    /* file:line */
  1506.  
  1507.     PL_get_arg(1, file, arg);
  1508.     if ( !PL_get_atom(arg, &loc.file) )
  1509.       return warning("$record_clause/3: instantiation fault");
  1510.     PL_get_arg(2, file, arg);
  1511.     if ( !PL_get_integer(arg, &loc.line) )
  1512.       return warning("$record_clause/3: instantiation fault");
  1513.   }
  1514.  
  1515.   if ( (clause = assert_term(term, CL_END, &loc)) )
  1516.     return PL_unify_pointer(ref, clause);
  1517.   
  1518.   fail;
  1519. }  
  1520.  
  1521.  
  1522. word
  1523. pl_redefine_system_predicate(term_t pred)
  1524. { Procedure proc;
  1525.   Module m = NULL;
  1526.   functor_t fd;
  1527.   term_t head = PL_new_term_ref();
  1528.  
  1529.   if ( !PL_strip_module(pred, &m, head) ||
  1530.        !PL_get_functor(head, &fd) )
  1531.     return warning("redefine_system_predicate/1: instantiation fault");
  1532.  
  1533.   proc = lookupProcedure(fd, m);
  1534.   abolishProcedure(proc, m);
  1535.  
  1536.   succeed;
  1537. }
  1538.  
  1539.  
  1540.         /********************************
  1541.         *          DECOMPILER           *
  1542.         *********************************/
  1543.  
  1544. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1545. decompileArg1()  is  a  simplified  version   of  decompileHead().   Its
  1546. function is to extract the relevant   information  for (re)computing the
  1547. index information for indexing on the   first argument (the 99.9% case).
  1548. See reindexClause().
  1549. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1550.  
  1551. int
  1552. arg1Key(Clause clause, word *key)
  1553. { Code PC = clause->codes;
  1554.  
  1555.   for(;;)
  1556.   { code c = decode(*PC++);
  1557.  
  1558. #if O_DEBUGGER
  1559.   again:
  1560. #endif
  1561.     switch(c)
  1562.     { case H_FUNCTOR:
  1563.       case H_RFUNCTOR:
  1564.     *key = ((functor_t)*PC);
  1565.         succeed;
  1566.       case H_CONST:
  1567.     *key = *PC;
  1568.     succeed;
  1569.       case H_NIL:
  1570.     *key = ATOM_nil;
  1571.         succeed;
  1572.       case H_LIST:
  1573.       case H_RLIST:
  1574.     *key = FUNCTOR_dot2;
  1575.         succeed;
  1576.       case H_INTEGER:
  1577.       case H_FLOAT:            /* tbd */
  1578.       case H_INDIRECT:
  1579.       case H_FIRSTVAR:
  1580.       case H_VAR:
  1581.       case H_VOID:
  1582.       case I_EXITFACT:
  1583.       case I_EXIT:            /* fact */
  1584.       case I_ENTER:            /* fix H_VOID, H_VOID, I_ENTER */
  1585.     fail;
  1586.       case I_NOP:
  1587.     continue;
  1588. #ifdef O_DEBUGGER
  1589.       case D_BREAK:
  1590.         c = decode(replacedBreak(PC-1));
  1591.     goto again;
  1592. #endif
  1593.       default:
  1594.     assert(0);
  1595.         fail;
  1596.     }
  1597.   }
  1598. }
  1599.  
  1600.  
  1601. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1602. The decompiler is rather straightforwards.  First it  will  construct  a
  1603. term  with  variables  for  the  head  and an array of variables for all
  1604. variables in  the  clause.   Next  the  head  arguments  are  filled  by
  1605. decompiling  the head code.  Finally the body is decompiled.  The latter
  1606. is slightly more complex as it is given in reverse polish notation.   We
  1607. first  will  skip  the  argument  filling  code,  looking for the actual
  1608. calling code.  This provides us the functor and arity of the  subclause.
  1609. Then we create a term, back up and fill the arguments.
  1610. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1611.  
  1612. #undef PC
  1613. #define PC    (di->pc)
  1614. #define ARGP    (di->argp)
  1615. #define XR(c)    ((word)(c))
  1616.  
  1617. typedef struct
  1618. { Code     pc;                /* pc for decompilation */
  1619.   Word     argp;                /* argument pointer */
  1620.   int     nvars;                /* size of var block */
  1621.   term_t *variables;            /* variable table */
  1622.   term_t bindings;            /* [Offset = Var, ...] */
  1623. } decompileInfo;
  1624.  
  1625. forwards bool    decompile_head(Clause, term_t, decompileInfo *);
  1626. forwards bool    decompileBody(decompileInfo *, code, Code);
  1627. forwards void    build_term(functor_t, decompileInfo *);
  1628.  
  1629. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1630. decompileHead()  is  public  as  it  is   needed  to  update  the  index
  1631. information for clauses if this changes   when  the predicate is already
  1632. defined.  Also for intermediate  code  file   loaded  clauses  the index
  1633. information is recalculated as the constants   may  be different accross
  1634. runs.
  1635. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1636.  
  1637. #define setHandle(h, w)        (*valTermRef(h) = (w))
  1638. #define valHandleP(h)        valTermRef(h)
  1639.  
  1640. static inline word
  1641. valHandle(term_t r)
  1642. { Word p = valTermRef(r);
  1643.  
  1644.   deRef(p);
  1645.   return *p;
  1646. }
  1647.  
  1648. bool
  1649. decompileHead(Clause clause, term_t head)
  1650. { decompileInfo di;
  1651.   di.nvars     = VAROFFSET(1) + clause->prolog_vars;
  1652.   di.variables = alloca(di.nvars * sizeof(term_t));
  1653.   di.bindings  = 0;
  1654.  
  1655.   return decompile_head(clause, head, &di);
  1656. }
  1657.  
  1658.  
  1659. static void
  1660. get_arg_ref(term_t term, term_t argp)
  1661. { word w = valHandle(term);
  1662.   setHandle(argp, makeRef(argTermP(w, 0)));
  1663. }
  1664.  
  1665.  
  1666. static void
  1667. next_arg_ref(term_t argp)
  1668. { Word p = valTermRef(argp);
  1669.   
  1670.   *p = makeRef(unRef(*p)+1);
  1671. }
  1672.  
  1673.  
  1674. static bool
  1675. unifyVar(Word var, term_t *vars, int i)
  1676. { DEBUG(3, Sdprintf("unifyVar(%d, %d, %d)\n", var, vars, i) );
  1677.  
  1678.   assert(vars[i]);
  1679.  
  1680.   return unify_ptrs(var, valTermRef(vars[i]));
  1681. }
  1682.  
  1683.  
  1684. static bool
  1685. decompile_head(Clause clause, term_t head, decompileInfo *di)
  1686. { int arity;
  1687.   term_t argp;
  1688.   int argn = 0;
  1689.   int pushed = 0;
  1690.   Definition def = clause->procedure->definition;
  1691.  
  1692.   if ( di->bindings )
  1693.   { term_t *p = &di->variables[VAROFFSET(0)];
  1694.     term_t tail = PL_copy_term_ref(di->bindings);
  1695.     term_t head = PL_new_term_ref();
  1696.     int n;
  1697.  
  1698.     for(n=0; n<clause->prolog_vars; n++)
  1699.     { p[n] = PL_new_term_ref();
  1700.  
  1701.       if ( !PL_unify_list(tail, head, tail) ||
  1702.        !PL_unify_term(head, PL_FUNCTOR, FUNCTOR_equals2,
  1703.                       PL_INTEGER, n,
  1704.                         PL_TERM, p[n]) )
  1705.     fail;
  1706.     }
  1707.     TRY(PL_unify_nil(tail));
  1708.   } else
  1709.   { term_t *p = &di->variables[VAROFFSET(0)];
  1710.     int n;
  1711.  
  1712.     for(n=0; n<clause->prolog_vars; n++)
  1713.       p[n] = PL_new_term_ref();
  1714.   }
  1715.  
  1716.   argp  = PL_new_term_ref();
  1717.  
  1718.   DEBUG(5, Sdprintf("Decompiling head of %s\n", predicateName(def)));
  1719.   arity = def->functor->arity;
  1720.   TRY( PL_unify_functor(head, def->functor->functor) );
  1721.   if ( arity > 0 )
  1722.     get_arg_ref(head, argp);
  1723.   PC = clause->codes;
  1724.  
  1725. #define NEXTARG { next_arg_ref(argp); if ( !pushed ) argn++; }
  1726.  
  1727.   for(;;)
  1728.   { code c = decode(*PC++);
  1729.  
  1730. #if O_DEBUGGER
  1731.   again:
  1732. #endif
  1733.     switch(c)
  1734.     { case I_NOP:
  1735.     continue;
  1736. #if O_DEBUGGER
  1737.       case D_BREAK:
  1738.     c = decode(replacedBreak(PC-1));
  1739.         goto again;
  1740. #endif
  1741.       case H_NIL:
  1742.     TRY(PL_unify_nil(argp));
  1743.         NEXTARG;
  1744.         continue;
  1745.       case H_INDIRECT:
  1746.         { word copy = globalIndirectFromCode(&PC);
  1747.       TRY(_PL_unify_atomic(argp, copy));
  1748.       NEXTARG;
  1749.       continue;
  1750.     }
  1751.       case H_INTEGER:
  1752.         { word copy = globalLong(XR(*PC++));
  1753.       TRY(_PL_unify_atomic(argp, copy));
  1754.       NEXTARG;
  1755.       continue;
  1756.     }
  1757.       case H_FLOAT:
  1758.         { Word p = allocGlobal(4);
  1759.       word w;
  1760.  
  1761.       w = consPtr(p, TAG_FLOAT|STG_GLOBAL);
  1762.       *p++ = mkIndHdr(2, TAG_FLOAT);
  1763.       *p++ = (long)XR(*PC++);
  1764.       *p++ = (long)XR(*PC++);
  1765.       *p++ = mkIndHdr(2, TAG_FLOAT);
  1766.       TRY(_PL_unify_atomic(argp, w));
  1767.       NEXTARG;
  1768.       continue;
  1769.     }
  1770.       case H_CONST:
  1771.       TRY(_PL_unify_atomic(argp, XR(*PC++)));
  1772.           NEXTARG;
  1773.       continue;
  1774.       case H_FIRSTVAR:
  1775.       case H_VAR:
  1776.       TRY(unifyVar(valTermRef(argp), di->variables, *PC++) );
  1777.           NEXTARG;
  1778.       continue;
  1779.       case H_VOID:
  1780.     { if ( !pushed )        /* FIRSTVAR in the head */
  1781.         TRY(unifyVar(valTermRef(argp), di->variables, VAROFFSET(argn)) );
  1782.       NEXTARG;
  1783.       continue;
  1784.     }
  1785.       case H_FUNCTOR:
  1786.     { functor_t fdef = (functor_t) XR(*PC++);
  1787.       term_t t2;
  1788.  
  1789.       common_functor:
  1790.       t2 = PL_new_term_ref();
  1791.       TRY(PL_unify_functor(argp, fdef));
  1792.           get_arg_ref(argp, t2);
  1793.           next_arg_ref(argp);
  1794.       argp = t2;
  1795.       pushed++;
  1796.       continue;
  1797.       case H_LIST:
  1798.       fdef = FUNCTOR_dot2;
  1799.           goto common_functor;
  1800.     }
  1801.       case H_RFUNCTOR:
  1802.     { functor_t fdef = (functor_t) XR(*PC++);
  1803.  
  1804.       common_rfunctor:
  1805.       TRY(PL_unify_functor(argp, fdef));
  1806.           get_arg_ref(argp, argp);
  1807.       continue;
  1808.       case H_RLIST:
  1809.       fdef = FUNCTOR_dot2;
  1810.           goto common_rfunctor;
  1811.     }
  1812.       case I_POPF:
  1813.       PL_reset_term_refs(argp);
  1814.           argp--;
  1815.       pushed--;
  1816.       if ( !pushed )
  1817.         argn++;
  1818.       continue;
  1819.       case I_EXITFACT:
  1820.       case I_EXIT:            /* fact */
  1821.       case I_ENTER:            /* fix H_VOID, H_VOID, I_ENTER */
  1822.     { assert(argn <= arity);
  1823.       for(; argn < arity; argn++)
  1824.       { TRY(unifyVar(valTermRef(argp), di->variables, VAROFFSET(argn)));
  1825.         next_arg_ref(argp);
  1826.       }
  1827.  
  1828.       succeed;
  1829.     }
  1830.       default:
  1831.       sysError("Illegal instruction in clause head: %d = %d",
  1832.            PC[-1], decode(PC[-1]));
  1833.       fail;
  1834.     }
  1835. #undef NEXTARG
  1836.   }
  1837. }
  1838.  
  1839. #define makeVarRef(i)    ((i)<<LMASK_BITS|TAG_REFERENCE)
  1840. #define isVarRef(w)    ((tag(w) == TAG_REFERENCE && \
  1841.               storage(w) == STG_INLINE) ? valInt(w) : -1)
  1842.  
  1843. bool
  1844. decompile(Clause clause, term_t term, term_t bindings)
  1845. { decompileInfo dinfo;
  1846.   decompileInfo *di = &dinfo;
  1847.   Word body;
  1848.  
  1849.   di->nvars     = VAROFFSET(1) + clause->prolog_vars;
  1850.   di->variables = alloca(di->nvars * sizeof(term_t));
  1851.   di->bindings  = bindings;
  1852.  
  1853. #ifdef O_RUNTIME
  1854.   if ( false(clause->procedure->definition, DYNAMIC) )
  1855.     fail;
  1856. #endif
  1857.  
  1858.   if ( true(clause, UNIT_CLAUSE) )    /* fact */
  1859.   { return decompile_head(clause, term, di);
  1860.   } else
  1861.   { term_t a = PL_new_term_ref();
  1862.  
  1863.     TRY(PL_unify_functor(term, FUNCTOR_prove2));
  1864.     PL_get_arg(1, term, a);
  1865.     TRY(decompile_head(clause, a, di));
  1866.     PL_get_arg(2, term, a);
  1867.     body = valTermRef(a);
  1868.     deRef(body);
  1869.   }
  1870.  
  1871.   ARGP = (Word) lTop;
  1872.  
  1873.   decompileBody(di, I_EXIT, (Code) NULL);
  1874.  
  1875.   { Word b;
  1876.     int var;
  1877.  
  1878.     b = newTerm();
  1879.     ARGP--;
  1880.     if ( (var = isVarRef(*ARGP)) >= 0 )
  1881.       unifyVar(b, di->variables, var);
  1882.     else
  1883.       *b = *ARGP;
  1884.  
  1885.     return unify_ptrs(body, b);
  1886.   }
  1887. }
  1888.  
  1889.  
  1890. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1891. Body decompilation.  A previous version of this part of the code  worked
  1892. top-down,  refining the term given using unification.  This approach has
  1893. three advantages:
  1894.  
  1895.   - Decompilation will fail as soon as  unification  of  generated  code
  1896.     fails.
  1897.   - If the body is instantiated no copy will be created  on  the  global
  1898.     stack, thus saving memory.
  1899.   - Handling variables is somewhat simpler as no intermediate storage is
  1900.     needed.
  1901.  
  1902. Unfortunately it also has some serious disadvantages:
  1903.  
  1904.   - The call/depart code is written in reverse polish notation.   If  we
  1905.     work  top-down  we  will need the functor of the subclause before we
  1906.     can start working on the arguments.  This implies we  have  to  skip
  1907.     the  argument instructions first to find the call/depart instruction
  1908.     and then back-up to fill the arguments, introducing one  more  place
  1909.     where we need to know the WAM code semantics.
  1910.   - With the  introduction  of  nested  reverse  polish  constructs  for
  1911.     arithmic  it  gets  very  difficult  to do the decompilation without
  1912.     using a stack for  intermediate  data  storage,  building  the  term
  1913.     bottom-up.
  1914.  
  1915. In the current implementation the head is decompiled in the  unification
  1916. style  and the head is decompiled using a stack machine.  This takes the
  1917. best of both approaches: the head is not in reverse polish notation  and
  1918. is  not  unlikely  to be instantiated (retract/1), while it is very rare
  1919. that clause/retract are used with instantiated body.
  1920.  
  1921. The decompilation stack is located on top of the local  stack,  as  this
  1922. area is not in use during decompilation.
  1923. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1924.  
  1925. static bool
  1926. decompileBody(register decompileInfo *di, code end, Code until)
  1927. { int nested = 0;        /* nesting in FUNCTOR ... POP */
  1928.   int pushed = 0;        /* Subclauses pushed on the stack */
  1929.   code op;
  1930.  
  1931.   while( PC != until )
  1932.   { op = decode(*PC++);
  1933.  
  1934. #if O_DEBUGGER
  1935.   again:
  1936. #endif
  1937.     if ( op == end )
  1938.     { PC--;
  1939.       break;
  1940.     }
  1941.  
  1942.     switch( op )
  1943.     {
  1944. #if O_DEBUGGER
  1945.         case D_BREAK:        op = decode(replacedBreak(PC-1));
  1946.                 goto again;
  1947. #endif      
  1948.         case A_ENTER:
  1949.         case I_NOP:        continue;
  1950.     case B_CONST:
  1951.                 *ARGP++ = XR(*PC++);
  1952.                 continue;
  1953.     case B_NIL:
  1954.                 *ARGP++ = ATOM_nil;
  1955.                 continue;
  1956.     case B_INTEGER:
  1957.     case A_INTEGER:
  1958.                 *ARGP++ = makeNum(*PC++);
  1959.                 continue;
  1960.     case B_FLOAT:
  1961.     case A_DOUBLE:
  1962.                 { union
  1963.                 { unsigned long w[2];
  1964.                   double f;
  1965.                 } v;
  1966.                 v.w[0] = *PC++;
  1967.                 v.w[1] = *PC++;
  1968.                 *ARGP++ = globalReal(v.f);
  1969.                 continue;
  1970.               }
  1971.     case B_INDIRECT:
  1972.                   *ARGP++ = globalIndirectFromCode(&PC);
  1973.                 continue;
  1974.       { register int index;      
  1975.  
  1976.     case B_ARGVAR:
  1977.     case B_ARGFIRSTVAR:
  1978.     case B_FIRSTVAR:
  1979.     case A_VAR:
  1980.     case B_VAR:        index = *PC++;        goto var_common;
  1981.     case A_VAR0:
  1982.     case B_VAR0:        index = VAROFFSET(0);    goto var_common;
  1983.     case A_VAR1:
  1984.     case B_VAR1:        index = VAROFFSET(1);    goto var_common;
  1985.     case A_VAR2:
  1986.     case B_VAR2:        index = VAROFFSET(2);    var_common:
  1987.                 if ( nested )
  1988.                   unifyVar(ARGP++, di->variables, index);
  1989.                 else
  1990.                   *ARGP++ = makeVarRef(index);
  1991.                 continue;
  1992.       }
  1993.       case B_VOID:
  1994.                 setVar(*ARGP++);
  1995.                 continue;
  1996.       case B_FUNCTOR:
  1997.       { functor_t fdef = (functor_t)XR(*PC++);
  1998.  
  1999.       common_bfunctor:
  2000.     *ARGP = globalFunctor(fdef);
  2001.         *aTop++ = ARGP + 1;
  2002.         verifyStack(argument);
  2003.     ARGP = argTermP(*ARGP, 0);
  2004.     nested++;
  2005.     continue;
  2006.       case B_LIST:
  2007.     fdef = FUNCTOR_dot2;
  2008.         goto common_bfunctor;
  2009.       }
  2010.       case B_RFUNCTOR:
  2011.       { functor_t fdef = (functor_t)XR(*PC++);
  2012.  
  2013.       common_brfunctor:
  2014.     *ARGP = globalFunctor(fdef);
  2015.     ARGP = argTermP(*ARGP, 0);
  2016.     continue;
  2017.       case B_RLIST:
  2018.     fdef = FUNCTOR_dot2;
  2019.         goto common_brfunctor;
  2020.       }
  2021.       case I_POPF:
  2022.                 ARGP = *--aTop;
  2023.                 nested--;
  2024.                 continue;
  2025. #if O_COMPILE_ARITH
  2026.       case A_FUNC0:
  2027.       case A_FUNC1:
  2028.       case A_FUNC2:
  2029.                 build_term(functorArithFunction(*PC++), di);
  2030.                 continue;
  2031.       case A_FUNC:
  2032.                       build_term(functorArithFunction(*PC++), di);
  2033.                       PC++;
  2034.                 continue;
  2035. #endif /* O_COMPILE_ARITH */
  2036.       { functor_t f;
  2037. #if O_COMPILE_ARITH
  2038.     case A_LT:        f = FUNCTOR_smaller2;    goto f_common;
  2039.     case A_LE:        f = FUNCTOR_smaller_equal2;    goto f_common;
  2040.     case A_GT:        f = FUNCTOR_larger2;    goto f_common;
  2041.     case A_GE:        f = FUNCTOR_larger_equal2;    goto f_common;
  2042.     case A_EQ:        f = FUNCTOR_ar_equals2;    goto f_common;
  2043.     case A_NE:        f = FUNCTOR_ar_not_equal2;    goto f_common;
  2044.     case A_IS:        f = FUNCTOR_is2;        goto f_common;
  2045. #endif /* O_COMPILE_ARITH */
  2046. #if O_BLOCK
  2047.     case I_CUT_BLOCK:   f = FUNCTOR_dcut1;        goto f_common;
  2048.     case B_EXIT:        f = FUNCTOR_dexit2;        goto f_common;
  2049. #endif
  2050. #if O_CATCHTHROW
  2051.     case B_THROW:        f = FUNCTOR_dthrow1;    goto f_common;
  2052. #endif
  2053.         case I_USERCALLN:   f = lookupFunctorDef(ATOM_call, *PC++ + 1);
  2054.                             goto f_common;
  2055.     case I_APPLY:        f = FUNCTOR_apply2;        f_common:
  2056.                 build_term(f, di);
  2057.                 pushed++;
  2058.                 continue;
  2059.       }
  2060.       case I_FAIL:        *ARGP++ = ATOM_fail;
  2061.                 pushed++;
  2062.                 continue;
  2063.       case I_TRUE:        *ARGP++ = ATOM_true;
  2064.                 pushed++;
  2065.                 continue;
  2066.       case I_CUT:        *ARGP++ = ATOM_cut;
  2067.                 pushed++;
  2068.                 continue;
  2069.       case I_DEPART:
  2070.       case I_CALL:        { Procedure proc = (Procedure)XR(*PC++);
  2071.                 build_term(proc->definition->functor->functor, di);
  2072.                 pushed++;
  2073.                 continue;
  2074.               }
  2075.       case I_USERCALL0:
  2076.                 pushed++;
  2077.                 continue;
  2078. #if O_INLINE_FOREIGNS
  2079.       case I_CALL_FV0:            /* proc */
  2080.       case I_CALL_FV1:            /* proc, var */
  2081.       case I_CALL_FV2:            /* proc, var, var */
  2082.       { int vars = op - I_CALL_FV0;
  2083.     int i;
  2084.  
  2085.     for(i=0; i<vars; i++)
  2086.     { int index = PC[i+1];        /* = B_VAR <N> (never nested!) */
  2087.       
  2088.       *ARGP++ = makeVarRef(index);
  2089.     }
  2090.     build_term(((Procedure)XR(*PC))->definition->functor->functor, di);
  2091.     pushed++;
  2092.     PC += vars+1;
  2093.     continue;
  2094.       }
  2095. #endif /*O_INLINE_FOREIGNS*/
  2096. #if O_COMPILE_OR
  2097. #define DECOMPILETOJUMP { int to_jump = (int) *PC++; \
  2098.               decompileBody(di, (code)-1, PC+to_jump); \
  2099.             }
  2100.       case C_CUT:
  2101.       case C_VAR:
  2102.       case C_JMP:
  2103.                 PC++;
  2104.                 continue;
  2105.       case C_OR:                /* A ; B */
  2106.                 DECOMPILETOJUMP;    /* A */
  2107.                 PC--;        /* get C_JMP argument */
  2108.                 DECOMPILETOJUMP;    /* B */
  2109.                 build_term(FUNCTOR_semicolon2, di);
  2110.                 pushed++;
  2111.                 continue;
  2112.       case C_NOT:                /* \+ A */
  2113.               { PC += 2;        /* skip the two arguments */
  2114.                 decompileBody(di, C_CUT, (Code)NULL);   /* A */
  2115.                 PC += 3;        /* skip C_CUT <n> and C_FAIL */
  2116.                 build_term(FUNCTOR_not_provable1, di);
  2117.                 pushed++;
  2118.                 continue;
  2119.               }
  2120.               { Code adr1;
  2121.                 int jmp;
  2122.                 code icut;
  2123.                 functor_t f;
  2124.       case C_SOFTIF:                /* A *-> B ; C */
  2125.                 icut = C_SOFTCUT;
  2126.                 f = FUNCTOR_softcut2;
  2127.                 goto ifcommon;
  2128.       case C_IFTHENELSE:            /* A  -> B ; C */
  2129.                 icut = C_CUT;
  2130.                 f = FUNCTOR_ifthen2;
  2131.             ifcommon:
  2132.                 PC++;        /* skip the 'MARK' variable */
  2133.                 jmp  = (int) *PC++;
  2134.                 adr1 = PC+jmp;
  2135.  
  2136.                 decompileBody(di, icut, (Code)NULL);   /* A */
  2137.                 PC += 2;        /* skip the cut */
  2138.                 decompileBody(di, (code)-1, adr1);        /* B */
  2139.                 build_term(f, di);
  2140.                 PC--;
  2141.                 DECOMPILETOJUMP;    /* C */
  2142.                 build_term(FUNCTOR_semicolon2, di);
  2143.                 pushed++;
  2144.                 continue;
  2145.               }
  2146.       case C_MARK:                /* A -> B */
  2147.                 PC++;
  2148.                 decompileBody(di, C_CUT, (Code)NULL);   /* A */
  2149.                 PC += 2;
  2150.                 decompileBody(di, C_END, (Code)NULL);   /* B */
  2151.                 PC++;
  2152.                 build_term(FUNCTOR_ifthen2, di);
  2153.                 pushed++;
  2154.                 continue;
  2155. #endif /* O_COMPILE_OR */
  2156.       case I_EXIT:
  2157.                 break;
  2158.       default:
  2159.       sysError("Illegal instruction in clause body: %d", PC[-1]);
  2160.       /*NOTREACHED*/
  2161.     }
  2162.   }
  2163.  
  2164.   while( pushed-- > 1)
  2165.     build_term(FUNCTOR_comma2, di);
  2166.  
  2167.   succeed;
  2168. }
  2169.  
  2170. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2171. Build the actual term.  The arguments are on  the  decompilation  stack.
  2172. We  construct a term of requested arity and name, copy `arity' arguments
  2173. from the stack into the term and finally  push  the  term  back  on  the
  2174. stack.
  2175. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2176.  
  2177. static void
  2178. build_term(functor_t f, decompileInfo *di)
  2179. { word term;
  2180.   int arity = arityFunctor(f);
  2181.   Word a;
  2182.  
  2183.   if ( arity == 0 )
  2184.   { *ARGP++ = nameFunctor(f);
  2185.     return;
  2186.   }    
  2187.  
  2188.   term = globalFunctor(f);
  2189.   a = argTermP(term, arity-1);
  2190.  
  2191.   ARGP--;
  2192.   for( ; arity-- > 0; a--, ARGP-- )
  2193.   { register int var;
  2194.  
  2195.     if ( (var = isVarRef(*ARGP)) >= 0 )
  2196.       unifyVar(a, di->variables, var);
  2197.     else
  2198.       *a = *ARGP;
  2199.   }
  2200.   ARGP++;
  2201.  
  2202.   *ARGP++ = term;
  2203. }
  2204.  
  2205. #undef PC
  2206. #undef ARGP
  2207.  
  2208. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2209. unify_definition(?Head, +Def, -TheHead, flags)
  2210.     Given some definition, unify its Prolog reference (i.e. its head with
  2211.     optional module specifier) with ?Head.  If TheHead is specified, the
  2212.     plain head (i.e. without module specifier) will be referenced from
  2213.     this term-reference.
  2214.  
  2215.     This function properly deals with module-inheritance, etc.
  2216. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2217.  
  2218. static int
  2219. unify_functor(term_t t, functor_t fd, int how)
  2220. { if ( how&GP_NAMEARITY )
  2221.   { FunctorDef fdef = valueFunctor(fd);
  2222.  
  2223.     return PL_unify_term(t,
  2224.              PL_FUNCTOR, FUNCTOR_divide2,
  2225.                PL_ATOM, fdef->name,
  2226.                PL_INTEGER, fdef->arity);
  2227.   } else
  2228.   { return PL_unify_functor(t, fd);
  2229.   }
  2230. }
  2231.  
  2232.  
  2233. int
  2234. unify_definition(term_t head, Definition def, term_t thehead, int how)
  2235. { if ( PL_is_variable(head) )
  2236.   { if ( def->module == MODULE_user )
  2237.     { unify_functor(head, def->functor->functor, how);
  2238.       if ( thehead )
  2239.     PL_put_term(thehead, head);
  2240.     } else
  2241.     { term_t tmp = PL_new_term_ref();
  2242.       
  2243.       PL_unify_functor(head, FUNCTOR_module2);
  2244.       PL_get_arg(1, head, tmp);
  2245.       PL_unify_atom(tmp, def->module->name);
  2246.       PL_get_arg(2, head, tmp);
  2247.       unify_functor(tmp, def->functor->functor, how);
  2248.       if ( thehead )
  2249.     PL_put_term(thehead, tmp);
  2250.     }
  2251.  
  2252.     succeed;
  2253.   } else
  2254.   { term_t h = PL_new_term_ref();
  2255.     Module m = NULL;
  2256.  
  2257.     if ( !PL_strip_module(head, &m, h) ||
  2258.      !isSuperModule(def->module, m) )
  2259.       fail;
  2260.  
  2261.     if ( unify_functor(h, def->functor->functor, how) )
  2262.     { if ( thehead )
  2263.     PL_put_term(thehead, h);
  2264.       succeed;
  2265.     }
  2266.  
  2267.     fail;
  2268.   }
  2269. }
  2270.  
  2271.  
  2272. word
  2273. pl_clause4(term_t p, term_t term, term_t ref, term_t bindings, word h)
  2274. { Procedure proc;
  2275.   Definition def;
  2276.   ClauseRef cref;
  2277.   Word argv;
  2278.   Module module = NULL;
  2279.  
  2280.   switch( ForeignControl(h) )
  2281.   { case FRG_FIRST_CALL:
  2282.     { Clause clause;
  2283.  
  2284.       if ( PL_get_pointer(ref, (void **)&clause) ) /* clause(H, B, 2733843) */
  2285.       { Module defModule;
  2286.     term_t tmp  = PL_new_term_ref();
  2287.     term_t head = PL_new_term_ref();
  2288.     term_t body = PL_new_term_ref();
  2289.     functor_t f;
  2290.     
  2291.     if ( !inCore(clause) || !isClause(clause) )
  2292.       return warning("clause/3: Invalid reference");
  2293.         
  2294.     if ( !decompile(clause, term, bindings) )
  2295.       fail;
  2296.     
  2297.     proc = clause->procedure;
  2298.     def = proc->definition;
  2299.     defModule = def->module;
  2300.     
  2301.     if ( PL_get_functor(term, &f) && f == FUNCTOR_module2 )
  2302.     { PL_strip_module(p, &module, tmp);
  2303.       if ( module != defModule )
  2304.         fail;
  2305.     }
  2306.     
  2307.     if ( !unify_definition(p, def, tmp, 0) )
  2308.       fail;
  2309.     
  2310.     get_head_and_body_clause(term, head, body, NULL);
  2311.     
  2312.     return PL_unify(tmp, head);
  2313.       }
  2314.       if ( !get_procedure(p, &proc, 0, GP_FIND) ||
  2315.        true(proc->definition, FOREIGN) )
  2316.     fail;
  2317.       def = proc->definition;
  2318.       cref = def->definition.clauses;
  2319.       enterDefinition(def);        /* reference the predicate */
  2320.       break;
  2321.     }
  2322.     case FRG_REDO:
  2323.     { cref = ForeignContextPtr(h);
  2324.       proc = cref->clause->procedure;
  2325.       def  = proc->definition;
  2326.       break;
  2327.     }
  2328.     case FRG_CUTTED:
  2329.     default:
  2330.     { cref = ForeignContextPtr(h);
  2331.       def  = cref->clause->procedure->definition;
  2332.  
  2333.       leaveDefinition(def);
  2334.       succeed;
  2335.     }
  2336.   }
  2337.  
  2338.   if ( def->functor->arity > 0 )
  2339.   { term_t head = PL_new_term_ref();
  2340.  
  2341.     PL_strip_module(p, &module, head);
  2342.     argv = valTermRef(head);
  2343.     deRef(argv);
  2344.     argv = argTermP(*argv, 0);
  2345.   } else
  2346.     argv = NULL;
  2347.  
  2348.   for(; cref; cref = cref->next)
  2349.   { bool det;
  2350.  
  2351.     if ( !(cref = findClause(cref, argv, def, &det)) )
  2352.     { leaveDefinition(def);
  2353.       fail;
  2354.     }
  2355.  
  2356.     if ( !decompile(cref->clause, term, bindings) )
  2357.       continue;
  2358.     if ( !PL_unify_pointer(ref, cref->clause) )
  2359.       continue;
  2360.  
  2361.     if ( det == TRUE )
  2362.     { leaveDefinition(def);
  2363.       succeed;
  2364.     }
  2365.  
  2366.     ForeignRedoPtr(cref->next);
  2367.   }
  2368.  
  2369.   fail;
  2370. }
  2371.  
  2372.  
  2373. word
  2374. pl_clause(term_t p, term_t term, term_t ref, word h)
  2375. { return pl_clause4(p, term, ref, 0, h);
  2376. }
  2377.  
  2378.  
  2379. typedef struct
  2380. { ClauseRef clause;            /* pointer to the clause */
  2381.   int       index;            /* nth-1 index */
  2382. } crref, *Cref;
  2383.  
  2384.  
  2385. word
  2386. pl_nth_clause(term_t p, term_t n, term_t ref, word h)
  2387. { Clause clause;
  2388.   ClauseRef cref;
  2389.   Procedure proc;
  2390.   Definition def;
  2391.   Cref cr;
  2392.  
  2393.   if ( ForeignControl(h) == FRG_CUTTED )
  2394.   { cr = ForeignContextPtr(h);
  2395.     def = cr->clause->clause->procedure->definition;
  2396.     leaveDefinition(def);
  2397.     freeHeap(cr, sizeof(crref));
  2398.     succeed;
  2399.   }
  2400.  
  2401.   if ( PL_get_pointer(ref, (void **)&clause) )
  2402.   { int i;
  2403.  
  2404.     if (!inCore(clause) || !isClause(clause))
  2405.       return warning("nth_clause/3: Invalid integer reference");
  2406.     
  2407.     proc = clause->procedure;
  2408.     def  = proc->definition;
  2409.     for( cref = def->definition.clauses, i=1; cref; cref = cref->next, i++)
  2410.     { if ( cref->clause == clause )
  2411.       { if ( !PL_unify_integer(n, i) ||
  2412.          !unify_definition(p, def, 0, 0) )
  2413.       fail;
  2414.  
  2415.     succeed;
  2416.       }
  2417.     }
  2418.  
  2419.     fail;
  2420.   }
  2421.  
  2422.   if ( ForeignControl(h) == FRG_FIRST_CALL )
  2423.   { int i;
  2424.  
  2425.     if ( !get_procedure(p, &proc, 0, GP_FIND) ||
  2426.          true(proc->definition, FOREIGN) )
  2427.       fail;
  2428.  
  2429.     def = proc->definition;
  2430.     cref = def->definition.clauses;
  2431.     while ( cref && true(cref->clause, ERASED) )
  2432.       cref = cref->next;
  2433.     
  2434.     if ( !cref )
  2435.       fail;
  2436.  
  2437.     if ( PL_get_integer(n, &i) )    /* proc and n specified */
  2438.     { i--;                /* 0-based */
  2439.  
  2440.       while(i > 0 && cref)
  2441.       { do
  2442.     { cref = cref->next;
  2443.     } while ( cref && true(cref->clause, ERASED) );
  2444.  
  2445.     i--;
  2446.       }
  2447.       if ( i == 0 && cref )
  2448.     return PL_unify_pointer(ref, cref->clause);
  2449.       fail;
  2450.     }
  2451.  
  2452.     cr = allocHeap(sizeof(crref));
  2453.     cr->clause = cref;
  2454.     cr->index  = 1;
  2455.     enterDefinition(def);
  2456.   } else
  2457.   { cr = ForeignContextPtr(h);
  2458.     def = cr->clause->clause->procedure->definition;
  2459.   }
  2460.  
  2461.   PL_unify_integer(n, cr->index);
  2462.   PL_unify_pointer(ref, cr->clause->clause);
  2463.  
  2464.   cref = cr->clause->next;
  2465.   while ( cref && true(cref->clause, ERASED) )
  2466.     cref = cref->next;
  2467.  
  2468.   if ( cref )
  2469.   { cr->clause = cref;
  2470.     cr->index++;
  2471.     ForeignRedoPtr(cr);
  2472.   }
  2473.  
  2474.   freeHeap(cr, sizeof(crref));
  2475.   leaveDefinition(def);
  2476.  
  2477.   succeed;
  2478. }
  2479.  
  2480. #if O_DEBUGGER                /* to the end of the file */
  2481.  
  2482. static Code
  2483. stepPC(Code PC)
  2484. { code op = decode(*PC++);
  2485.  
  2486.   if ( codeTable[op].argtype == CA1_STRING )
  2487.   { word m = *PC++;
  2488.     PC += wsizeofInd(m);
  2489.   }
  2490.  
  2491.   PC += codeTable[op].arguments;
  2492.  
  2493.   return PC;
  2494. }
  2495.  
  2496.  
  2497. static int
  2498. wouldBindToDefinition(Definition from, Definition to)
  2499. { Module m = from->module;
  2500.   Definition def = from;
  2501.   Procedure proc;
  2502.  
  2503.   for(;;)
  2504.   { if ( def )
  2505.     { if ( def == to )            /* found it */
  2506.     succeed;
  2507.  
  2508.       if ( def->definition.clauses ||    /* defined and not the same */
  2509.        true(def, DYNAMIC|MULTIFILE|DISCONTIGUOUS) ||
  2510.        false(def->module, UNKNOWN) )
  2511.     fail;
  2512.     }
  2513.  
  2514.     if ( (m = m->super) )
  2515.     { proc = isCurrentProcedure(from->functor->functor, m);
  2516.       def = proc ? proc->definition : (Definition)NULL;
  2517.     } else
  2518.       break;
  2519.   }
  2520.  
  2521.   fail;
  2522. }
  2523.  
  2524.  
  2525. word
  2526. pl_xr_member(term_t ref, term_t term, word h)
  2527. { Clause clause;
  2528.   Code PC;
  2529.   Code end;
  2530.  
  2531.   if ( ForeignControl(h) == FRG_CUTTED )
  2532.     succeed;
  2533.  
  2534.   if ( !PL_get_pointer(ref, (void **)&clause) ||
  2535.        !inCore(clause) || !isClause(clause) )
  2536.     return warning("$xr_member/2: Invalid reference");
  2537.  
  2538.   PC  = clause->codes;
  2539.   end = &PC[clause->code_size];
  2540.  
  2541.   if ( PL_is_variable(term) )
  2542.   { if ( ForeignControl(h) != FRG_FIRST_CALL)
  2543.     { long i = ForeignContextInt(h);
  2544.  
  2545.       PC += i;
  2546.     }
  2547.  
  2548.     while( PC < end )
  2549.     { bool rval = FALSE;
  2550.       code op = decode(*PC++);
  2551.       
  2552. #ifdef O_DEBUGGER
  2553.       if ( op == D_BREAK )
  2554.     op = decode(replacedBreak(PC-1));
  2555. #endif
  2556.  
  2557.       switch(codeTable[op].argtype)
  2558.       { case CA1_PROC:
  2559.     { Procedure proc = (Procedure) *PC;
  2560.       rval = unify_definition(term, proc->definition, 0, 0);
  2561.       break;
  2562.     }
  2563.     case CA1_FUNC:
  2564.     { functor_t fd = (functor_t) *PC;
  2565.       rval = PL_unify_functor(term, fd);
  2566.       break;
  2567.     }
  2568.     case CA1_DATA:
  2569.     { word xr = *PC;
  2570.       rval = _PL_unify_atomic(term, xr);
  2571.       break;
  2572.     }
  2573.     case CA1_INTEGER:
  2574.     case CA1_FLOAT:
  2575.       break;
  2576.     case CA1_STRING:
  2577.     { word m = *PC++;
  2578.       PC += wsizeofInd(m);
  2579.       break;
  2580.     }
  2581.       }
  2582.  
  2583.       PC += codeTable[op].arguments;
  2584.  
  2585.       if ( rval )
  2586.       { long i = PC - clause->codes;    /* compensate ++ above! */
  2587.  
  2588.     ForeignRedoInt(i);
  2589.       }
  2590.     }
  2591.  
  2592.     fail;
  2593.   } else                /* instantiated */
  2594.   { Procedure proc;
  2595.     functor_t fd;
  2596.  
  2597.     if ( PL_is_atomic(term) )
  2598.     { while( PC < end )
  2599.       { code op = decode(*PC);
  2600.  
  2601.     if ( codeTable[op].argtype == CA1_DATA &&
  2602.          _PL_unify_atomic(term, PC[1]) )
  2603.         succeed;
  2604.  
  2605.     PC = stepPC(PC);
  2606.       }
  2607.     } else if ( PL_get_functor(term, &fd) && fd != FUNCTOR_module2 )
  2608.     { while( PC < end )
  2609.       { code op = decode(*PC);
  2610.  
  2611.     if ( codeTable[op].argtype == CA1_FUNC )
  2612.     { functor_t fa = (functor_t)PC[1];
  2613.  
  2614.       if ( fa == fd )
  2615.       { DEBUG(1,
  2616.           { term_t ref = PL_new_term_ref();
  2617.             long i;
  2618.             
  2619.             PL_unify_pointer(ref, clause);
  2620.             PL_get_long(ref, &i);
  2621.             Sdprintf("Got it, clause %d at %d\n",
  2622.                  i, PC-clause->codes);
  2623.           });
  2624.         succeed;
  2625.       }
  2626.     }
  2627.  
  2628.     PC = stepPC(PC);
  2629.       }
  2630.     } else if ( get_procedure(term, &proc, 0, GP_FIND) )
  2631.     { while( PC < end )
  2632.       { code op = decode(*PC);
  2633.  
  2634.     if ( codeTable[op].argtype == CA1_PROC )
  2635.     { Procedure pa = (Procedure)PC[1];
  2636.  
  2637.       if ( pa->definition == proc->definition )
  2638.         succeed;
  2639.       if ( pa->definition->functor == proc->definition->functor &&
  2640.            wouldBindToDefinition(pa->definition, proc->definition) )
  2641.         succeed;
  2642.     }
  2643.  
  2644.     PC = stepPC(PC);
  2645.       }
  2646.     }
  2647.   }
  2648.  
  2649.   fail;
  2650. }
  2651.  
  2652.          /*******************************
  2653.          *         WAM_LIST        *
  2654.          *******************************/
  2655.  
  2656. #define VARNUM(i) ((i) - (ARGOFFSET / (int) sizeof(word)))
  2657.  
  2658. void
  2659. wamListClause(Clause clause)
  2660. { Code bp, ep;
  2661.  
  2662.   bp = clause->codes;
  2663.   ep = bp + clause->code_size;
  2664.  
  2665.   while( bp < ep )
  2666.   { code op = decode(*bp);
  2667.     const code_info *ci;
  2668.     int n = 0;
  2669.     int isbreak;
  2670.  
  2671.     if ( op == D_BREAK )
  2672.     { op = decode(replacedBreak(bp));
  2673.       isbreak = TRUE;
  2674.     } else
  2675.       isbreak = FALSE;
  2676.  
  2677.     ci = &codeTable[op];
  2678.  
  2679.     Putf("%4d %s", bp - clause->codes, ci->name);
  2680.     bp++;
  2681.  
  2682.     switch(op)
  2683.     { case B_FIRSTVAR:
  2684.       case H_FIRSTVAR:
  2685.       case B_ARGFIRSTVAR:
  2686.       case B_VAR:
  2687.       case B_ARGVAR:
  2688.       case H_VAR:
  2689.       case C_VAR:
  2690.       case C_MARK:
  2691.       case C_SOFTCUT:
  2692.       case C_CUT:            /* var */
  2693.     assert(ci->arguments == 1);
  2694.     Putf(" var(%d)", VARNUM(*bp++));
  2695.     break;
  2696.       case C_SOFTIF:
  2697.       case C_IFTHENELSE:        /* var, jump */
  2698.       case C_NOT:
  2699.       { int var = VARNUM(*bp++);
  2700.     int jmp = *bp++;
  2701.     assert(ci->arguments == 2);
  2702.         Putf(" var(%d), jmp(%d)", var, jmp);
  2703.         break;
  2704.       }
  2705.       case I_CALL_FV1:
  2706.       case I_CALL_FV2:
  2707.       { int vars = op - I_CALL_FV0;
  2708.     Procedure proc = (Procedure) *bp++;
  2709.  
  2710.     Putf(" %s", procedureName(proc));
  2711.     for( ; vars > 0; vars-- )
  2712.       Putf(", var(%d)", VARNUM(*bp++));
  2713.         break;
  2714.       }
  2715.       default:
  2716.     switch(codeTable[op].argtype)
  2717.     { case CA1_PROC:
  2718.       { Procedure proc = (Procedure) *bp++;
  2719.         n++;
  2720.         Putf(" %s", procedureName(proc));
  2721.         break;
  2722.       }
  2723.       case CA1_FUNC:
  2724.       { functor_t f = (functor_t) *bp++;
  2725.         FunctorDef fd = valueFunctor(f);
  2726.         n++;
  2727.         Putf(" %s/%d", stringAtom(fd->name), fd->arity);
  2728.         break;
  2729.       }
  2730.       case CA1_DATA:
  2731.       { word xr = *bp++;
  2732.         n++;
  2733.         switch(tag(xr))
  2734.         { case TAG_ATOM:
  2735.         Putf(" %s", stringAtom(xr));
  2736.             break;
  2737.           case TAG_INTEGER:
  2738.         Putf(" %ld", valInteger(xr));
  2739.             break;
  2740.           case TAG_STRING:
  2741.         Putf(" \"%s\"", valString(xr));
  2742.             break;
  2743.           default:
  2744.         assert(0);
  2745.         }
  2746.         break;
  2747.       }
  2748.       case CA1_INTEGER:
  2749.       { long l = (long) *bp++;
  2750.         n++;
  2751.         Putf(" %ld", l);
  2752.         break;
  2753.       }
  2754.       case CA1_FLOAT:
  2755.       { union { word w[2];
  2756.             double f;
  2757.           } v;
  2758.         n += 2;
  2759.         v.w[0] = *bp++;
  2760.         v.w[1] = *bp++;
  2761.         Putf(" %g", v.f);
  2762.         break;
  2763.       }
  2764.       case CA1_STRING:
  2765.       { word m = *bp++;
  2766.         int  n = wsizeofInd(m);
  2767.         Putf(" \"%s\"", (char *)bp);
  2768.         bp += n;
  2769.         break;
  2770.       }
  2771.     }
  2772.         for(; n < codeTable[op].arguments; n++ )
  2773.       Putf("%s%d", n == 0 ? " " : ", ", *bp++);
  2774.     }
  2775.  
  2776.     if ( isbreak )
  2777.       Putf(" *break*");
  2778.  
  2779.     Putf("\n");
  2780.   }
  2781. }
  2782.  
  2783.  
  2784. word
  2785. pl_wam_list(term_t ref)
  2786. { Clause clause;
  2787.  
  2788.   if ( !PL_get_pointer(ref, (void **)&clause) ||
  2789.        !inCore(clause) || !isClause(clause) )
  2790.     return warning("$wam_list/1: Invalid reference");
  2791.  
  2792.   wamListClause(clause);
  2793.  
  2794.   succeed;
  2795. }
  2796.  
  2797.  
  2798. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2799. $fetch_vm(+Clause, +Offset, -NextOffset, -Instruction)
  2800.     fetches the virtual machine instruction at the indicated position
  2801.     and return NextOffset with the offset of the next instruction, or
  2802.     [] if there is no next instruction.  Instruction is unified with
  2803.     a descriptive term of the instruction, but for now only with the
  2804.     name of the instruction.
  2805. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2806.  
  2807. word
  2808. pl_fetch_vm(term_t ref, term_t offset, term_t noffset, term_t instruction)
  2809. { Clause clause;
  2810.   int pcoffset;
  2811.   Code PC;
  2812.   code op;
  2813.   const code_info *ci;
  2814.  
  2815.   if ( !PL_get_pointer(ref, (void **)&clause) ||
  2816.        !inCore(clause) || !isClause(clause) ||
  2817.        !PL_get_integer(offset, &pcoffset) ||
  2818.        pcoffset < 0 || pcoffset >= clause->code_size )
  2819.     return warning("$fetch_vm/4: instantiation fault");
  2820.  
  2821.   PC = clause->codes + pcoffset;
  2822.   op = decode(*PC);
  2823.   if ( op == D_BREAK )
  2824.     op = decode(replacedBreak(PC));
  2825.   ci = &codeTable[op];
  2826.   
  2827.   pcoffset = pcoffset + 1 + ci->arguments;
  2828.  
  2829.   if ( PL_unify_integer(noffset, pcoffset) &&
  2830.        PL_unify_atom_chars(instruction, ci->name) )
  2831.     succeed;
  2832.  
  2833.   fail;
  2834. }
  2835.  
  2836.  
  2837.  
  2838.          /*******************************
  2839.          *     SOURCE LEVEL DEBUGGER    *
  2840.          *******************************/
  2841.  
  2842. static Code
  2843. find_code1(Code PC, code fop, code ctx)
  2844. { for(;;)
  2845.   { code op = decode(*PC++);
  2846.  
  2847.     if ( op == D_BREAK )
  2848.       op = decode(replacedBreak(PC-1));
  2849.  
  2850.     if ( fop == op && ctx == *PC )
  2851.       return &PC[-1];
  2852.     assert(op != I_EXIT);
  2853.  
  2854.     PC += codeTable[op].arguments;
  2855.   }
  2856. }
  2857.  
  2858.  
  2859. static Code
  2860. find_code0(Code PC, code fop)
  2861. { for(;;)
  2862.   { code op = decode(*PC++);
  2863.  
  2864.     if ( op == D_BREAK )
  2865.       op = decode(replacedBreak(PC-1));
  2866.     if ( fop == op )
  2867.       return &PC[-1];
  2868.     assert(op != I_EXIT);
  2869.  
  2870.     PC += codeTable[op].arguments;
  2871.   }
  2872. }
  2873.  
  2874.  
  2875. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2876. $clause_term_position(+ClauseRef, +PCoffset, -TermPos)
  2877.     Find the term-location of the call that ends in the given PC offset.
  2878.     The term-position is a list of argument-numbers one has to use from
  2879.     the clause-term to find the subterm that sets up the goal.
  2880. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2881.  
  2882. /*
  2883. #undef DEBUG
  2884. #define DEBUG(l, g) g
  2885. */
  2886.  
  2887. static int
  2888. add_node(term_t tail, int n)
  2889. { term_t h = PL_new_term_ref();
  2890.   int rval;
  2891.  
  2892.   rval = PL_unify_list(tail, h, tail) && PL_unify_integer(h, n);
  2893.   PL_reset_term_refs(h);
  2894.  
  2895.   DEBUG(1, Sdprintf("Added %d\n", n));
  2896.  
  2897.   return rval;
  2898. }
  2899.  
  2900.  
  2901. static void
  2902. add_1_if_not_at_end(Code PC, Code end, term_t tail)
  2903. { while(PC < end && decode(*PC) == C_VAR )
  2904.     PC += 2;
  2905.  
  2906.   if ( PC != end )
  2907.     add_node(tail, 1);
  2908. }
  2909.  
  2910.  
  2911.  
  2912. word
  2913. pl_clause_term_position(term_t ref, term_t pc, term_t locterm)
  2914. { Clause clause;
  2915.   int pcoffset;
  2916.   Code PC, loc, end;
  2917.   term_t tail = PL_copy_term_ref(locterm);
  2918.  
  2919.   if ( !PL_get_pointer(ref, (void **)&clause) ||
  2920.        !inCore(clause) || !isClause(clause) ||
  2921.        !PL_get_integer(pc, &pcoffset) ||
  2922.        pcoffset < 0 || pcoffset > clause->code_size )
  2923.     return warning("$clause_location/3: invalid argument");
  2924.  
  2925.   PC = clause->codes;
  2926.   loc = &PC[pcoffset];
  2927.   end = &PC[clause->code_size - 1];    /* forget the final I_EXIT */
  2928.  
  2929.   while( PC < loc )
  2930.   { code op = decode(*PC++);
  2931.     const code_info *ci;
  2932.  
  2933.     if ( op == D_BREAK )
  2934.       op = decode(replacedBreak(PC-1));
  2935.     ci = &codeTable[op];
  2936.  
  2937.     switch(op)
  2938.     { case I_ENTER:
  2939.     if ( loc == PC )
  2940.     { add_node(tail, 1);
  2941.  
  2942.       return PL_unify_nil(tail);
  2943.     }
  2944.     add_node(tail, 2);
  2945.     continue;
  2946.       case I_EXIT:
  2947.       case I_EXITFACT:
  2948.     if ( loc == PC )
  2949.     { return PL_unify_nil(tail);
  2950.     }
  2951.         continue;
  2952.     { Code endloc;
  2953.       case C_OR:            /* C_OR <jmp1> <A> C_JMP <jmp2> <B> */
  2954.       { Code jmploc = PC + *PC++ + 1;
  2955.  
  2956.     endloc = jmploc + jmploc[-1];
  2957.  
  2958.     DEBUG(1, Sdprintf("jmp = %d, end = %d\n",
  2959.               jmploc - clause->codes, endloc - clause->codes));
  2960.  
  2961.     if ( loc <= endloc )        /* loc is in the disjunction */
  2962.     { add_1_if_not_at_end(endloc, end, tail);
  2963.  
  2964.       if ( loc <= jmploc )        /* loc is in first branch */
  2965.       { add_node(tail, 1);
  2966.         end = jmploc-2;
  2967.         continue;
  2968.       }
  2969.                     /* loc is in second branch */
  2970.       add_node(tail, 2);
  2971.       PC = jmploc;
  2972.       end = endloc;
  2973.       continue;
  2974.     }
  2975.  
  2976.       after_construct:
  2977.     add_node(tail, 2);        /* loc is after disjunction */
  2978.     PC = endloc;
  2979.     continue;
  2980.       }
  2981.       case C_NOT:        /* C_NOT <var> <jmp> <A> C_CUT <var>, C_FAIL */
  2982.       { endloc = PC + PC[1] + 2;
  2983.  
  2984.     DEBUG(1, Sdprintf("not: PC= %d, endloc = %d\n",
  2985.               PC - clause->codes, endloc - clause->codes));
  2986.  
  2987.     if ( loc <= endloc )        /* in the \+ argument */
  2988.     { add_1_if_not_at_end(endloc, end, tail);
  2989.  
  2990.       add_node(tail, 1);
  2991.       PC += 2;
  2992.       end = endloc-3;        /* C_CUT <var>, C_FAIL */
  2993.       continue;
  2994.     }
  2995.  
  2996.     goto after_construct;
  2997.       }
  2998.       case C_SOFTIF:
  2999.       case C_IFTHENELSE:    /* C_IFTHENELSE <var> <jmp1> */
  3000.                 /* <IF> C_CUT <THEN> C_JMP <jmp2> <ELSE> */
  3001.       { Code elseloc = PC + PC[1] + 2;
  3002.     code cut = (op == C_IFTHENELSE ? C_CUT : C_SOFTCUT);
  3003.  
  3004.     endloc = elseloc + elseloc[-1];
  3005.  
  3006.     DEBUG(1, Sdprintf("else = %d, end = %d\n",
  3007.               elseloc - clause->codes, endloc - clause->codes));
  3008.  
  3009.     if ( loc <= endloc )
  3010.     { add_1_if_not_at_end(endloc, end, tail);
  3011.  
  3012.       if ( loc <= elseloc )        /* a->b */
  3013.       { Code cutloc = find_code1(&PC[2], cut, PC[0]);
  3014.  
  3015.         DEBUG(1, Sdprintf("cut at %d\n", cutloc - clause->codes));
  3016.         add_node(tail, 1);
  3017.         
  3018.         if ( loc <= cutloc )    /* a */
  3019.         { add_node(tail, 1);
  3020.           end = cutloc;
  3021.           PC = &PC[2];
  3022.         } else            /* b */
  3023.         { add_node(tail, 2);
  3024.           PC = cutloc + 2;
  3025.           end = elseloc-2;
  3026.         }    
  3027.         DEBUG(1, Sdprintf("end = %d\n", end - clause->codes));
  3028.         continue;
  3029.       }
  3030.                     /* c */
  3031.       add_node(tail, 2);
  3032.       PC = elseloc;
  3033.       end = endloc;
  3034.       continue;
  3035.     }
  3036.  
  3037.     goto after_construct;
  3038.       }
  3039.       case C_MARK:        /* A -> B */
  3040.                 /* C_MARK <var> <A> C_CUT <var> <B> C_END */
  3041.       { Code cutloc = find_code1(&PC[1], C_CUT, PC[0]);
  3042.     
  3043.     endloc = find_code0(cutloc+2, C_END);
  3044.  
  3045.     if ( loc <= endloc )
  3046.     { add_1_if_not_at_end(endloc, end, tail);
  3047.  
  3048.       if ( loc <= cutloc )        /* a */
  3049.       { add_node(tail, 1);
  3050.  
  3051.         PC += 1;
  3052.         end = cutloc;
  3053.       } else            /* b */
  3054.       { add_node(tail, 2);
  3055.         PC = cutloc+2;
  3056.         end = endloc;
  3057.       }
  3058.  
  3059.       continue;
  3060.     }
  3061.  
  3062.     goto after_construct;
  3063.       }
  3064.       }                    /* closes the special constructs */
  3065.       case I_CALL:
  3066.       case I_DEPART:
  3067.       case I_CUT:
  3068.       case I_FAIL:
  3069.       case I_TRUE:
  3070.       case I_APPLY:
  3071.       case I_USERCALL0:
  3072.       case I_USERCALLN:
  3073.       case I_CALL_FV0:
  3074.       case I_CALL_FV1:
  3075.       case I_CALL_FV2:
  3076.     PC += ci->arguments;
  3077.         if ( loc == PC )
  3078.     { add_1_if_not_at_end(PC, end, tail);
  3079.  
  3080.       return PL_unify_nil(tail);
  3081.     }
  3082.     add_node(tail, 2);
  3083.     continue;
  3084.       default:
  3085.     PC += ci->arguments;
  3086.     }
  3087.   }
  3088.  
  3089.   fail;                    /* assert(0) */
  3090. }
  3091.  
  3092.  
  3093. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3094. Generate (on backtracing), all  possible   break-points  of  the clause.
  3095. Works in combination with pl_clause_term_position()   to  find the place
  3096. for placing a break-point.
  3097. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3098.  
  3099. word
  3100. pl_break_pc(term_t ref, term_t pc, term_t nextpc, control_t h)
  3101. { Clause clause;
  3102.   int offset;
  3103.   Code PC, end;
  3104.  
  3105.   switch( ForeignControl(h) )
  3106.   { case FRG_CUTTED:
  3107.       succeed;
  3108.     case FRG_FIRST_CALL:
  3109.       offset = 0;
  3110.     case FRG_REDO:
  3111.     default:
  3112.       offset = ForeignContextInt(h);
  3113.   }
  3114.  
  3115.   
  3116.   if ( !PL_get_pointer(ref, (void **)&clause) ||
  3117.        !inCore(clause) || !isClause(clause) )
  3118.     fail;
  3119.   PC = clause->codes + offset;
  3120.   end = clause->codes + clause->code_size;
  3121.  
  3122.   while( PC < end )
  3123.   { code op = decode(*PC);
  3124.     Code next;
  3125.  
  3126.     if ( op == D_BREAK )
  3127.       op = decode(replacedBreak(PC));
  3128.     next = PC + 1 + codeTable[op].arguments;
  3129.  
  3130.     switch(op)
  3131.     { case I_ENTER:
  3132.       case I_EXIT:
  3133.       case I_EXITFACT:
  3134.       case I_CALL:
  3135.       case I_DEPART:
  3136.       case I_CUT:
  3137.       case I_FAIL:
  3138.       case I_TRUE:
  3139.       case I_APPLY:
  3140.       case I_USERCALL0:
  3141.       case I_USERCALLN:
  3142.       case I_CALL_FV0:
  3143.       case I_CALL_FV1:
  3144.       case I_CALL_FV2:
  3145.     if ( PL_unify_integer(pc, PC-clause->codes) &&
  3146.          PL_unify_integer(nextpc, next-clause->codes) )
  3147.       ForeignRedoInt(next-clause->codes);
  3148.     }
  3149.  
  3150.     PC = next;
  3151.   }
  3152.  
  3153.   fail;
  3154. }
  3155.  
  3156.          /*******************************
  3157.          *         BREAK-POINTS        *
  3158.          *******************************/
  3159.  
  3160. #define breakTable (GD->comp.breakpoints)
  3161.  
  3162. typedef struct
  3163. { Clause    clause;            /* Associated clause */
  3164.   int        offset;            /* Offset of the instruction */
  3165.   code        saved_instruction;    /* The instruction saved */
  3166. } break_point, *BreakPoint;
  3167.  
  3168.  
  3169. static bool
  3170. setBreak(Clause clause, int offset)
  3171. { Code PC = clause->codes + offset;
  3172.  
  3173.   if ( !breakTable )
  3174.     breakTable = newHTable(16);
  3175.  
  3176.   if ( *PC != encode(D_BREAK) )
  3177.   { BreakPoint bp = allocHeap(sizeof(break_point));
  3178.  
  3179.     bp->clause = clause;
  3180.     bp->offset = offset;
  3181.     bp->saved_instruction = *PC;
  3182.  
  3183.     addHTable(breakTable, PC, bp);
  3184.     *PC = encode(D_BREAK);
  3185.     set(clause, HAS_BREAKPOINTS);
  3186.  
  3187.     callEventHook(PLEV_BREAK, clause, offset);
  3188.     succeed;
  3189.   }
  3190.  
  3191.   fail;
  3192. }
  3193.  
  3194.  
  3195. static int
  3196. clearBreak(Clause clause, int offset)
  3197. { Code PC = clause->codes + offset;
  3198.   BreakPoint bp;
  3199.   Symbol s;
  3200.  
  3201.   if ( !breakTable || !(s=lookupHTable(breakTable, PC)) )
  3202.     fail;
  3203.  
  3204.   bp = (BreakPoint)s->value;
  3205.   *PC = bp->saved_instruction;
  3206.   freeHeap(bp, sizeof(*bp));
  3207.   deleteSymbolHTable(breakTable, s);
  3208.  
  3209.   callEventHook(PLEV_NOBREAK, clause, offset);
  3210.   succeed;
  3211. }
  3212.  
  3213.  
  3214. void
  3215. clearBreakPointsClause(Clause clause)
  3216. { if ( breakTable )
  3217.   { Symbol s, n;
  3218.  
  3219.     for( s = firstHTable(breakTable); s; s = n )
  3220.     { BreakPoint bp = (BreakPoint)s->value;
  3221.  
  3222.       n = nextHTable(breakTable, s);
  3223.  
  3224.       if ( bp->clause == clause )
  3225.     clearBreak(bp->clause, bp->offset);
  3226.     }    
  3227.   }
  3228.  
  3229.   clear(clause, HAS_BREAKPOINTS);
  3230. }
  3231.  
  3232.  
  3233. code
  3234. replacedBreak(Code PC)
  3235. { Symbol s;
  3236.   BreakPoint bp;
  3237.  
  3238.   if ( !breakTable || !(s=lookupHTable(breakTable, PC)) )
  3239.     return (code) sysError("No saved instruction for break");
  3240.   bp = (BreakPoint)s->value;
  3241.  
  3242.   return bp->saved_instruction;
  3243. }
  3244.  
  3245.  
  3246. word
  3247. pl_break_at(term_t ref, term_t pc, term_t set)
  3248. { Clause clause;
  3249.   int offset;
  3250.   atom_t a;
  3251.  
  3252.   if ( !PL_get_pointer(ref, (void **)&clause) ||
  3253.        !inCore(clause) || !isClause(clause) ||
  3254.        !PL_get_atom(set, &a) ||
  3255.        !PL_get_integer(pc, &offset) ||
  3256.        offset < 0 || offset >= clause->code_size )
  3257.     fail;
  3258.  
  3259.   if ( a == ATOM_true )
  3260.     return setBreak(clause, offset);
  3261.   else
  3262.     return clearBreak(clause, offset);
  3263. }
  3264.  
  3265.  
  3266. word
  3267. pl_current_break(term_t ref, term_t pc, control_t h)
  3268. { Symbol symb;
  3269.   
  3270.   if ( !breakTable )
  3271.     fail;
  3272.  
  3273.   switch( ForeignControl(h) )
  3274.   { case FRG_FIRST_CALL:
  3275.       symb = firstHTable(breakTable);
  3276.       break;
  3277.     case FRG_REDO:
  3278.       symb = ForeignContextPtr(h);
  3279.       break;
  3280.     case FRG_CUTTED:
  3281.     default:
  3282.       succeed;
  3283.   }
  3284.  
  3285.   for( ; symb; symb = nextHTable(breakTable, symb) )
  3286.   { BreakPoint bp = (BreakPoint) symb->value;
  3287.  
  3288.     { fid_t cid = PL_open_foreign_frame();
  3289.  
  3290.       if ( PL_unify_pointer(ref, bp->clause) &&
  3291.        PL_unify_integer(pc,  bp->offset) )
  3292.       { if ( !(symb = nextHTable(breakTable, symb)) )
  3293.       succeed;
  3294.  
  3295.     ForeignRedoPtr(symb);
  3296.       }
  3297.  
  3298.       PL_discard_foreign_frame(cid);
  3299.     }
  3300.   }
  3301.  
  3302.   fail;
  3303. }
  3304.  
  3305. #endif /*O_DEBUGGER*/
  3306.